無精・短気・傲慢

perlの事 いろいろ

chabo - AI(Artificial incompetence)

 リファクタ

cgiチャボをmojoliciousのモジュールに作り直した。サーバーサイドとフロントエンドを完全に分離しコードをスッキリ?させた。

チャボは入力文字列より単語を抽出しその単語よりマルコフ連鎖で文章を作成し出力する。

 mecab

日本語の文章を分かち書きするのにmecabを使用。mecabには内部文字列をencode(バイト列に変換)してmecabからの戻り値をdecode(内部文字列に変換)して使います。

use Encode;
use Text::MeCab;

sub text_parse{
    my $s = shift;
    my $text = shift;
    my $parser = Text::MeCab->new();
    my $n = $parser->parse(encode('utf-8',$text));
    my @ret = ();
    do{
        push(@ret,+{surface=>decode('utf-8',$n->surface),feature=>decode('utf-8',$n->feature)});
    } while ($n = $n->next);
    return \@ret;
}

 マルコフ連鎖

3連のマルコフデータをランダムに連結し人工無能的文書を作成する。

sub put_together{
    my $s = shift;
    my $word = shift||'わたし';
    my @words = ();
    my $dbh = $s->app->model->webdb->dbh;
    
    # 最初の一言
    my $sql = "select word1,word2 from @{[$s->markov]} where word1 like ? or word2 like ? order by rand() limit 1";
    my $data = $dbh->selectall_arrayref($sql,+{Slice => +{}},'%'.$word.'%','%'.$word.'%');
    push(@words,$data->[0]->{word1});
    push(@words,$data->[0]->{word2});

    # 後ろを作成
    $sql = "select word1,word2,word3 from @{[$s->markov]} where word1 = ? and word2 = ? order by rand() limit 1";
    my $sth = $dbh->prepare($sql);
    while(1){
        $sth->execute($words[-2],$words[-1]);
        if(my $ref = $sth->fetchrow_hashref()){
            if($ref->{word3} =~ /EOS/){
                last;
            }
            push(@words,$ref->{word3});
        }else{
            last;
        }
    }
    
    # 前を作成
    $sql = "select word1,word2,word3 from @{[$s->markov]} where word2 = ? and word3 = ? order by rand() limit 1";
    $sth = $dbh->prepare($sql);
    while(1){
        $sth->execute($words[0],$words[1]);
        if(my $ref = $sth->fetchrow_hashref()){
            unshift(@words,$ref->{word1});
        }else{
            last;
        }
    }
    return @words;
}

 ソース

  • サーバーサイド
package Tool::mmt::Controller::Chabo;
use Mojo::Base 'Tool::mmt::Controller::Json';

=head1 NAME
  chabo - AI(Artificial incompetence) chabo(chat bot) module
=cut

use Encode;
use Text::MeCab;

has chatdata => 'test.chatdata';
has markov => 'test.markov';

sub sample_parse{
    my $s = shift;
    my $r = $s->text_parse($s->get_para('text','テスト'));
    $s->json_or_jsonp( $s->render(json => $r, partial => 1));
}
sub sample_put_together{
    my $s = shift;
    my @t = (join('',$s->put_together($s->get_para('text','わたし'))));
    $s->json_or_jsonp( $s->render(json=>\@t,partial =>1));
}
sub sample_get_time_line{
    my $s = shift;
    my $r = $s->time_line();
    $s->json_or_jsonp( $s->render(json => $r, partial => 1));
}
sub talk{
    my $s = shift;
    my $r = $s->text_parse($s->get_para('text','わたし'));
    my $w = $s->select_word($r);
    my @ans = (join('',$s->put_together($w)));
    unshift(@ans,$w);
    $s->json_or_jsonp( $s->render(json=>\@ans,partial =>1));
}
sub chatbot{
    my $s = shift;
    my $name = $s->get_para('name','no name');
    my $action = $s->get_para('action','');
    my $chat = $s->get_para('chat','');
    my $id = $s->write_log($name,$chat);
    my $r = $s->text_parse($chat);
    my ($w,$ans);
    $w = $s->select_word($r);
    $ans = (join('',$s->put_together($w)));
    $ans = $s->arrange_text($ans);
    $s->put_markov($r,$id);
    $s->write_log('チャボ',$ans);
    $s->stash->{answer} = $ans;
}
sub arrange_text{
    my $s = shift;
    my $text = shift;
    $text =~ s/^RT@[^:]+://g;
    return $text;
}
sub write_log{
    my $s = shift;
    my $name = shift;
    my $chat = shift;
    return if($chat eq '');
    my $dbh = $s->app->model->webdb->dbh;
    $dbh->do("INSERT INTO  @{[$s->chatdata]} (name,chat) values (?,?)",undef,$name,$chat); 
    return $dbh->{mysql_insertid};
}
sub select_word{
    my $s = shift;
    my $ws = shift;
    my @a = grep {$_->{feature} =~ '名詞'} @$ws;
    return $a[int(rand scalar @a)]->{ surface };
}
sub get_para{
    my $s = shift;
    my $item = shift||'text';
    my $def = shift;
    my $t = $s->param($item);
    if ($t eq "") {
       $t = ref $s->req->json eq 'HASH' ? $s->req->json->{$item}  
                                        : $def;
    }
    return $t
} 
sub text_parse{
    my $s = shift;
    my $text = shift;
    my $parser = Text::MeCab->new();
    my $n = $parser->parse(encode('utf-8',$text));
    my @ret = ();
    do{
        push(@ret,+{surface=>decode('utf-8',$n->surface),feature=>decode('utf-8',$n->feature)});
    } while ($n = $n->next);
    return \@ret;
}
 
sub put_together{
    my $s = shift;
    my $word = shift||'わたし';
    my @words = ();
    my $dbh = $s->app->model->webdb->dbh;
    
    # 最初の一言
    my $sql = "select word1,word2 from @{[$s->markov]} where word1 like ? or word2 like ? order by rand() limit 1";
    my $data = $dbh->selectall_arrayref($sql,+{Slice => +{}},'%'.$word.'%','%'.$word.'%');
    push(@words,$data->[0]->{word1});
    push(@words,$data->[0]->{word2});

    # 後ろを作成
    $sql = "select word1,word2,word3 from @{[$s->markov]} where word1 = ? and word2 = ? order by rand() limit 1";
    my $sth = $dbh->prepare($sql);
    while(1){
        $sth->execute($words[-2],$words[-1]);
        if(my $ref = $sth->fetchrow_hashref()){
            if($ref->{word3} =~ /EOS/){
                last;
            }
            push(@words,$ref->{word3});
        }else{
            last;
        }
    }
    
    # 前を作成
    $sql = "select word1,word2,word3 from @{[$s->markov]} where word2 = ? and word3 = ? order by rand() limit 1";
    $sth = $dbh->prepare($sql);
    while(1){
        $sth->execute($words[0],$words[1]);
        if(my $ref = $sth->fetchrow_hashref()){
            unshift(@words,$ref->{word1});
        }else{
            last;
        }
    }
    return @words;
}
sub time_line{
    my $s = shift;
    my $limit = shift||50;
    my $start = shift||0; 
    my $dbh = $s->app->model->webdb->dbh;
    my $sql = "select UPD_TIME,name,chat from @{[$s->chatdata]} order by SEQ_NO desc limit ?,?";
    my $data = $dbh->selectall_arrayref($sql,+{Slice => +{}},$start,$limit);
    return $data;
} 
sub put_markov{
    my $s = shift;
    my $r = shift;
    my $id = shift;
    my $dbh = $s->app->model->webdb->dbh;
    my $sth = $dbh->prepare("insert @{[$s->markov]} (word1,word2,word3,chat_No,part)
						values (?,?,?,?,?)");
    if (@$r > 2 ) {
        # 「2語の接頭語と1語の接尾語」のマルコフ連鎖テーブルを作成
        # $markov{接頭語前}{接頭語後ろ}[no]=接尾語 の形式
        # $markov{$wakatigaki[0]}{$wakatigaki[1]}[]=$wakatigaki[2];

        for (my $i = 2 ; $i < @$r ; $i++) {
			$sth->execute($r->[$i-2]->{surface}
				,$r->[$i-1]->{surface},$r->[$i]->{surface}
				,$id,$r->[$i-2]->{feature});
        }
    }
}
1;
<html>
<head>
<title>chabo</title>
</head>
<body>
<answer><%= stash('answer') %></answer>
</body>
</html>
  • フロントエンド
#!/usr/bin/env perl
use utf8;
use Mojolicious::Lite;
use DateTime;
use Mojo::JSON;
use Mojo::UserAgent;
use Encode qw/from_to decode_utf8 encode_utf8 decode encode/;
use Data::Dumper qw/Dumper/;

get '/' => sub {
    my $self = shift;
} => 'index';

get '/time_line' => sub {
   my $s = shift;
   my $ua = Mojo::UserAgent->new;
   my $ans = $ua->get(Mojo::URL->new("http://www21051ue.sakura.ne.jp:3003/api/chabo/sample_get_time_line"))->res;
   $s->render(json => $ans->json);

};
my $clients = {};
websocket '/echo' => sub {
    my $self = shift;

    Mojo::IOLoop->stream($self->tx->connection)->timeout(0);
    app->log->debug(sprintf 'Client connected: %s', $self->tx);
    my $id = sprintf "%s", $self->tx;
    app->log->debug("id:".$id);
    $clients->{$id} = $self->tx;

    $self->on(message => sub {
        my ($self, $msg) = @_;

        my ($name,$message) = split(/\t/,$msg);
        $self->app->log->debug('name: ', $name, 'message: ', $message);
        unless($name){
            $name = '名無し';
        }

        my $json = Mojo::JSON->new;
        my $dt   = DateTime->now( time_zone => 'Asia/Tokyo');

        # チャボに話しかける  --- START
        my $ua = Mojo::UserAgent->new;
        my $name_euc = decode_utf8($name);
#        my $ans = $ua->get(Mojo::URL->new("http://www21051ue.sakura.ne.jp/chabo/chatbot_utf8.cgi?name=$name&action=TALK&chat=$message"))->res->body;
        my $ans = $ua->get(Mojo::URL->new("http://www21051ue.sakura.ne.jp:3003/api/chabo/chatbot?name=$name&action=TALK&chat=$message"))->res->body;
        my $txt = '';
        if($ans =~ m|<answer>(.*)</answer>|){
            $txt = decode('UTF-8',$1);
        }else{
            $txt = decode('UTF-8',$ans);
        }
        # チャボに話しかける  --- END

        for (keys %$clients) {
            $self->app->log->debug('clients', Dumper $clients->{$_});
            $clients->{$_}->send(
                decode_utf8($json->encode({
                    hms  => $dt->hms,
                    name => $name,
                    text => $message,
                }))
            );

            # チャボの話を拡散する  --- START
            if($txt ne ''){
                $clients->{$_}->send(
                    decode_utf8($json->encode({
                        hms  => $dt->hms,
                        name =>'チャボ',
                        text => $txt,
                    }))
                );
            }
            # チャボの話を拡散する  --- END
        }
    });

    $self->on(finish => sub {
        app->log->debug('Client disconnected');
        delete $clients->{$id};
    });
};

app->start;

__DATA__
@@ index.html.ep
% layout 'main';
%= javascript begin
jQuery(function($) {
  $('#msg').focus();

  // 1番下にスクロールする -- START
  var go_bottom = function(targetId){
    var $obj = $("#" + targetId);
    if ($obj.length == 0) return;
    $obj.scrollTop($obj[0].scrollHeight);
  };
  // 1番下にスクロールする -- END

  var log = function (text) {
//    $('#log').val( $('#log').val() + text + "\n");
//    go_bottom('log');
    $('#log2').append(text + '<br>');
    go_bottom('log2');
  };
  var time_line = function (){
    $.ajax({
        url: '/time_line',
        type: 'GET',
        dataType: 'json',
        success: function( data,textStatus,jqXHR){
            for(let j in data){
                let i = data.length - j - 1;
                log('[' + data[i].UPD_TIME + '] (' + data[i].name +  ') ' + data[i].chat);
            }
        }
    });
  };
  var ws = new WebSocket('<%= url_for('/echo')->to_abs->scheme('ws'); %>');
  ws.onopen = function () {
    log('Connection opened');
    time_line();
  };
  ws.onmessage = function (msg) {
    var res = JSON.parse(msg.data);
    log('[' + res.hms + '] (' + res.name + ') ' + res.text);
  };

  $('#msg').keydown(function (e) {
    if (e.keyCode == 13 && $('#msg').val()) {
        ws.send($('#name').val() + "\t" + $('#msg').val());
        $('#msg').val('');
    }
  });
    });
% end
<h1>Mojolicious + WebSocket</h1>
ここでの発言はチャボに記憶され何処かで引用される可能性が
有ります。ご注意下さい。<br />
<div class="ScrollBox" id="log2">
</div>

<p>name<input type="text" id="name" /><br />msg<input type="text" id="msg" size="80"/></p>
[<%= url_for('/echo')->to_abs->scheme('ws'); %>]
<div>
</div>

@@ layouts/main.html.ep
<html>
  <head>
    <meta charset="<%= app->renderer->encoding %>">
    <title>WebSocket Client</title>
    %= javascript 'https://ajax.googleapis.com/ajax/libs/jquery/1.7/jquery.min.js'
    <style type="text/css">
      textarea {
          width: 80em;
          height:20em;
      }
      div.ScrollBox {overflow:auto;width:1000px;height:350px;border:1px black solid;margin:0px}
    </style>
  </head>
  <body><%= content %></body>
</html>

 

JSONP

JSONP

JSONは情報をやり取りする際のフォーマットとして頻繁に使われるようになりました。

ただ、外部サービスと通信する際に、AjaxJSONをやり取りするには「クロスドメイン」という壁があります。つまり、他ドメインに属するファイルはAjaxでは基本的に取得出来ません。

そこでJSONPの出番です。

JSONPはJSON with Paddingの略称です。Paddingは(本来は不要なものの)付け足しという意味です。

-- Wikipediaより --

JSONP(JSON with padding)とは、scriptタグを使用してクロスドメインな(異なるドメインに存在する)データを取得する仕組みのことである。HTMLのscriptタグ、JavaScript(関数)、JSONを組み合わせて実現される。

     仕組

ウェブブラウザなどに実装されている「同一生成元ポリシー」という制約により、Webページは通常、自分を生成したドメイン以外のドメインのサーバと通信することはできない。 しかし、HTMLのscriptタグのsrc属性には別ドメインのURLを指定して通信することができるという点を利用することによって別ドメインのサーバからデータを取得することが可能になる。JSONPでは、通常、上記src属性のレスポンスの内容はjavascript関数呼び出しの形式となるため、src属性に指定するURLにその関数の名前をクエリ文字列の形式で付加する。一般的な方法では、この時に指定する関数名はWebページ側ですでに定義されているコールバック用の関数の名前になる。関数名を渡すリクエストパラメータの名前はサーバとクライアント間で事前に取り決めておく必要がある。例えば(callbackというパラメータ名でparseResponseという関数名を渡す場合)

   <script type='text/javascript' 
    src='http://another.domain.example.com/getjson?callback=parseResponse'> 

通常は、上記リクエストのレスポンスとして、JSON形式のデータを引数とする関数の呼び出し文が返される。 この関数の呼び出し文がブラウザにより解釈・実行されることで、データの受信完了の検知とコールバック処理が可能になっている。 上記の例では、parseResponseという関数の呼び出し文が返される。

 parseResponse({"Name":"Smith","Rank":7})

     注意点

JSONPでは、CSRF(cross-site request forgery)に対する脆弱性に注意が必要である。 このscriptタグを使う方法では同一生成元ポリシーが適用されず、またサーバのエンドポイントは外部に公開されているため、悪意のあるサイトが自分のページにscriptタグを埋め込み、別のサイトのJSONデータを取得するといったことが可能である。このため、機密情報や個人情報などのデータを取り扱うには不適切である。 また、scriptタグを埋め込む側においては、リモートサイトは任意の内容のデータをページに差し込むことが可能であるため、そのリモートサイトが悪意のあるサイトである場合やJavaScriptインジェクションに対する脆弱性がある場合は、その脆弱性を突かれることで、アカウント情報を盗まれたり、元のサイトも影響を受けたりする可能性がある。データを提供するサーバ側では、リクエストの正当性を検証するのが適切である。 但し、Cookieだけを使用した検証は、CSRFに対して脆弱であるため、不十分である。Dojo Toolkit、Google Web ToolkitなどのライブラリでJSONPがサポートされている。

     サンプル

[http://togawa.qee.jp/json02.html]

<head>
<meta charset="UTF-8">
<script type="text/javascript" src="http://ajax.googleapis.com/ajax/libs/jquery/1.7/jquery.min.js"></script> 
<script type="text/javascript"> 
function execute() { 
  $.ajax({
    type: 'GET',
      url: 'http://www21051ue.sakura.ne.jp/api/json/get',
      dataType: 'jsonp',
      success: function (data) {
        $("#container").html("<pre>" + JSON.stringify(data,null,"  ") + "</pre>");
      }
  });
} 
</script>
</head> 
<body> 
<H1>JSON</H1>
<button onclick="execute()">サンプル実行</button> 
<hr><div id="jsondata">content</div>
<hr><div id="container">JSON DATA</div>
</body> 
</html> 

package Tool::mmt::Controller::Json;
use Mojo::Base 'Tool::mmt::Controller::Mmt';

my $perl_object =  {head => 'Json Test Data',array=>[1,2,3,4],lang=>['perl','ruby','php'],
           日本語=>['漢字','ひらがな','カタカナ']};

sub json_post{
    my $s = shift;
    use Mojo::UserAgent;
    my $ua = Mojo::UserAgent->new;
    my $data = $ua->post('http://www21051ue.sakura.ne.jp:8888/index.cgi' =>
                               {Accept=> '*/*'} => json => $perl_object);
    if (my $res = $data->success){
        $s->render(data => $res->body ,format=>'html');
    }else{
        my ($err, $code) = $data->error;
        $s->render(data => $code ? "$code response: $err\n" : "Connection error: $err\n",
            format => 'text');
    }
}

sub json_test01{
    my $s = shift;
    $s->json_or_jsonp( $s->render(json => $perl_object, partial => 1)
        );
}

sub json{
    my $s = shift;
    $s->render(json => $s->req->json);
}
sub json_or_jsonp{
    my $s = shift;
    my $json = shift;
    my $callback = $s->param('callback');
    if($callback ne ""){
        $s->render(data => "$callback($json)",format => 'js');
    } else {
        $s->render(data => $json, format=>'json');
    }
}
sub get{
    my $s = shift;
    my $sql = "select name,chat from test.chatdata order by rand() limit 10";
    my $dbh = $s->app->model->webdb->dbh;
    my $data = $dbh->selectall_arrayref($sql,+{Slice => +{}});
    $s->json_or_jsonp( $s->render(json => $data, partial => 1));
}

1;

mojolicious memo

perl WAF

Mojolicious(モジョリシャス)はperl製のWebアプリケーションフレームワークです。2つのウェブサーバが同梱されていてmojoliciousだけセットアップすれはwebを開発、公開できます。1つはmorbo (モーボ)で開発用のサーバーです。起動しっぱなしでも起動後に更新されたモジュールがロードされます。もう1つのhypnotoad (ハイプノトード)はプリフォークサーバーでホットデプロイメントを行うことができます。

  • 起動
$ morbo script/<myApp>
→ Server available at http://127.0.0.1:3000
- or -
$ hypnotoad script/<myApp>

データベースにSQLiteを使えばサーバーを立てずにお手軽にWebを公開出来ます。

mojoliciousでJSONをPOSTで送信と受信

デモ画面を作ってみた。

[toolmmt/templates/json/json.html.ep]

% layout 'default';
% title 'mojplicious JSON DEMO';
<h1>mojolicious JSON Demo</h1>
<hr><h4>JSON</h4>
<ul>
  <li><a href="http://www21051ue.sakura.ne.jp:3003/api/json/json_test01">json_test001</a></li>
</ul>
<h4>JSON POST</h4>
<script type="text/javascript">
    $(function(){
        $("#response").html("Response Values");
        $("#button").click( function(){
            var url = $("#url_post").val();
                var JSONdata = {
                    value1: $("#value1").val(),
                    value2: $("#value2").val()      
                };
            // alert(JSON.stringify(JSONdata));
            $.ajax({
                type : 'post',
                url : url,
                data : JSON.stringify(JSONdata),
                contentType: 'application/JSON',
                dataType : 'JSON',
                scriptCharset: 'utf-8',
                success : function(data) {
                    // Success
                    // alert("success");
                    // alert(JSON.stringify(data));
                    $("#response").html(JSON.stringify(data));
                },
                error : function(data) {
                    // Error
                    alert("error");
                    alert(JSON.stringify(data));
                    $("#response").html(JSON.stringify(data));
                }
            });
        })
    })
</script>

    <h2>HTMLファイルからPOSTでJSONデータを送信する</h2>
    <p>URL: <input type="text" id="url_post" name="url" size="100" value="<%== url_for %>"></p>
    <p>value1: <input type="text" id="value1" size="30" value="値1"></p>
    <p>value2: <input type="text" id="value2" size="30" value="値2"></p>
    <p><button id="button" type="button">submit</button></p>
    <textarea id="response" cols=120 rows=10 disabled></textarea>


[toolmmt/lib/Tool/mmt/Controller/Json.pm]

package Tool::mmt::Controller::Json;
use Mojo::Base 'Tool::mmt::Controller::Mmt';

sub json_post{
    my $s = shift;
    use Mojo::UserAgent;
    my $ua = Mojo::UserAgent->new;
    my $data = $ua->post('http://localhost:3001/api/example/json' =>  {Accept=> '*/*'} => json => {a => 'b'});
    $s->render(json => $data->res->json);
}
sub json_test01{
    my $s = shift;
    $s->render(json => {head => 'Json Test Data',array=>[1,2,3,4],lang=>['perl','ruby','php'],
        日本語=>['漢字','ひらがな','カタカナ']});
}

sub json{
    my $s = shift;
    $s->render(json => $s->req->json);
}

1;

コントローラーのディレクトリが変わった

どのバージョンで変わったか解らないがコントローラーのディレクトリが変わっていた。以前はlib/<myApp>の下がコントローラだったがlib/<myApp>/Controller下になっていた。両方のバージョンで動かす為にはstartupにてnamespacesを設定する。

 $r->namespaces(['Tool::mmt::Controller']);

オプショナルなプレースホルダ

ふたつのオプショナルなプレースホルダーが、スラッシュによって分割されている場合だけ、 スラッシュはオプショナルなものになります。

 # /           -> {controller => 'foo',   action => 'bar'}
 # /users      -> {controller => 'users', action => 'bar'}
 # /users/list -> {controller => 'users', action => 'list'}
 $r->get('/:controller/:action')->to('foo#bar');

controllerやactionなどの特別なスタッシュの値もまたプレースホルダーとなりえます。これによってきわめて柔軟なルーティングの構築が可能になります。 これは開発の間は特にとても便利ですが、 すべてのコントローラーメソッドがルーティングになる可能性 があるので、注意深く利用すべきです。 アンダースコアで始まるこれらのメソッドと同じように、すべての大文字のメソッドは 自動的にルーターから隠されます。 追加的に隠すためにMojolicious::Routesのhideを使うこともできます。

/:controller/:actionでコントローラとアクション(メソッド)を柔軟に設定できます。

mojoliciousで作ったアプリ

 

中置記法から後置記法(逆ポーランド記法)への変換と計算

Calculation and conversion to postfix notation (Reverse Polish Notation) from infix notation

perlでは入力内容をevalすれば良いだけだけどアルゴリズム(algorithm)の備忘録として書いてみた。

使い方

$ perl calc.pl "((1+5)*(-2+-3) * -1)**2 % 8"
4$
$ perl calc.pl "6/2(1+2)"
1$

計算

[calc.pl]

use strict;
my $op = { '-' => [sub {@_[1] - @_[0]},1],
           '+' => [sub {@_[1] + @_[0]},1],
           '*' => [sub {@_[1] * @_[0]},2],
           '/' => [sub {@_[1] / @_[0]},2],
           '%' => [sub {@_[1] % @_[0]},2],
           '**' => [sub {@_[1] ** @_[0]},3],
           'x' => [sub {@_[1] * @_[0]},9], # 多項式対応?
           '(' => [sub { },0],
       };
# 中置記法の引数をスペースで分割し後置記法に変換し計算を行う
print calc(infix_to_postfix(split (/\s+/,adjust(pop))));

sub infix_to_postfix{      # 中置記法を後置記法に変換
    my @post = ();                                                     # 後置記法用スタック
    my @opr = ();                                                      # 演算子用のワークスタック
    for ('(',@_,')'){                                                  # 中置記法の要素をカッコでくくり(処理を単純にする為)先頭から最後まで処理を行う。
        if ($_ eq ")"){                                                # 要素が閉じカッコの場合
            push @post,pop @opr while( @opr && $opr[-1] ne "(" );      #     開きカッコまで演算子用スタックから要素を取出し後置記法用スタックに積む。
            pop @opr;                                                  #     開きカッコを読み捨てる。
        }elsif(exists $op->{$_}){                                      # 要素が演算子の場合
                                                                       #     要素が開きカッコでなく要素のプライオリティが低い間、
                                                                       #     演算子スタックを取出し後置記法用スタックに積む。
            push @post,pop @opr while($_ ne "(" && @opr && $op->{$_}->[1] <= $op->{$opr[-1]}->[1]);
            push @opr,$_;                                              #     要素を演算子スタックに積む。
        }else{                                                         # 要素が演算子以外の場合
            push @post,$_;                                             #     要素を後置記法用スタックに積む。     
        }
    }
    return @post;                                                      # 後置記法用スタックを返却する。
}
sub calc {                 # 逆ポーランド記法の計算
    my @stack = ();
                                                                       # 1.逆ポーランド記法の要素を先頭から最後まで処理を行う。
                                                                       # 2.要素が演算子の場合にスタックから2つの要素を取出し計算結果をスタックに積む。
                                                                       # 3.要素が演算子でない場合に要素をスタックに積む。
    push @stack,(exists $op->{$_} ?  $op->{$_}->[0](pop @stack,pop @stack) : $_) for @_;
    return pop @stack;                                                 # スタックから要素を取出し返却する。
}
sub adjust{
    my $text = shift;
    $text =~ s{([\-\+\*\/\%\(\)x])}{ $1 }g;
    $text =~ s{\s+}{ }g;
    $text =~ s{\* \*}{\*\*}g;
    $text =~ s{(\D\s+)\- (\d)}{$1 -$2}g;
    $text =~ s{([\d\)]\s+)\(}{$1 x (}g;    # 多項式対応?
    return $text;
} 
 

 

github

2016/01/23

githubはじめました。まだよく解りません。mmtを登録してみました。

https://github.com/john-smith-7701/

ソースをwikiに貼る作業が煩わしいのでgithubに登録してみました。

 

mmt -- Master Maintenance Tool perl module.

目的

mmt.pmをmojoliciousで書き直す。

github

https://github.com/john-smith-7701/mmt に登録した。

memo

初めの一歩

$ mojo generate app Tool::mmt
$ tree toolmmt
toolmmt
├── lib
│     └── Tool
│            ├── mmt
│            │     └── Example.pm
│            └── mmt.pm
├── log
├── public
│     └── index.html
├── script
│     └── toolmmt
├── t
│     └── basic.t
└── templates
       ├── example
       │     └── welcome.html.ep
       └── layouts
              └── default.html.ep

10 directories, 7 files
$ svn import toolmmt svn+ssh://userId@localhost/usr/local/svn/repos/toolmmt -m "Initial Import."
$ svn co svn+ssh://userId@www21051ue.sakura.ne.jp/usr/local/svn/repos/toolmmt

2015/11/10現在

$ tree -f |perl -alne '@x=split /\s+/,`wc -l $F[-1] 2>/dev/null`;$l=sprintf("%5d %s",$x[0],$_);$l=~ s/ 0 /   /;$l=~ s{\..*/}{};print $l'
      .
      ├── lib
      │   └── Tool
      │       ├── mmt
   13 │       │   ├── Example.pm
  512 │       │   └── Mmt.pm
   25 │       ├── mmt.pm
      │       ├── Model
   46 │       │   └── Webdb.pm
    7 │       └── Model.pm
      ├── log
 3979 │   └── development.log
      ├── public
   11 │   └── index.html
      ├── script
   11 │   └── toolmmt
    4 ├── svn-commit.tmp
      ├── t
    9 │   └── basic.t
      └── templates
          ├── example
    7     │   └── welcome.html.ep
          ├── layouts
    5     │   └── default.html.ep
          └── mmt
   27         ├── datalist.html.ep
    5         ├── desc.html.ep
   29         └── mainform.html.ep
      
      12 directories, 15 files
$

2015/11/21

とりあえず素のメンテ作成。cssJavaScript (12/9) も無し。

[2016/01/11]
     .
     ├── lib
     │   └── Tool
     │       ├── Model
     │       │   ├── Webdb
  29 │       │   │   └── constant.pm
 210 │       │   └── Webdb.pm
   7 │       ├── Model.pm
     │       ├── mmt
  35 │       │   ├── Commodity.pm
  13 │       │   ├── Example.pm
 759 │       │   ├── Mmt.pm
  19 │       │   └── Usertbl.pm
  28 │       └── mmt.pm
     ├── log
     ├── public
     │   ├── css
 121 │   │   └── default.css
  11 │   ├── index.html
     │   └── js
     ├── script
  11 │   └── toolmmt
   4 ├── svn-commit.tmp
     ├── t
   9 │   └── basic.t
     └── templates
         ├── example
   7     │   └── welcome.html.ep
         ├── layouts
  33     │   ├── default.html.ep
  32     │   └── defsubwin.html.ep
         └── mmt
  36         ├── datalist.html.ep
   9         ├── desc.html.ep
   4         ├── dumper.html.ep
  53         ├── mainform.html.ep
  32         └── subwin.html.ep
     
     15 directories, 21 files

構成

script/toolmmt # アプリケーションスクリプト

#!/usr/bin/env perl

use strict;
use warnings;

use FindBin;
BEGIN { unshift @INC, "$FindBin::Bin/../lib" }

# Start command line interface for application
require Mojolicious::Commands;
Mojolicious::Commands->start_app('Tool::mmt');

lib/Tool/mmt.pm # アプリケーションクラス(ルーター等)

package Tool::mmt;
use Mojo::Base 'Mojolicious';
use Tool::Model;

has 'model' => sub {Tool::Model->new};    # modelを追加
has 'controller' => "mmt";

# This method will run once at server start
sub startup {
  my $self = shift;

  # Documentation browser under "/perldoc"
  $self->plugin('PODRenderer');
  $self->plugin('TagHelpers');
  # Router
  my $r = $self->routes;
  # Normal route to controller
  $r->get('/')->to('example#welcome');
  $r->get('/mmt/:_table/desc')->to('mmt#desc');
  $r->get('/mmt/:_table')->to(controller => $self->controller,action =>'mainform');
  $r->post('/mmt/:_table')->to(controller => $self->controller,action => 'registry');
  $r->get('/mmtx/:controller')->to(controller => $self->controller,action =>'mainform');  # 特別なプレースフォルダ :controllerと:action 柔軟なルーティングの構築が可能になる
  $r->post('/mmtx/:controller')->to(controller => $self->controller,action => 'registry');
}

1;

lib/Tool/Model.pm

package Tool::Model;
use Mojo::Base 'Mojolicious';
use Tool::Model::Webdb;
has 'webdb' => sub { Tool::Model::Webdb->new };   # 自作モデルとか
1;

lib/Tool/Model/Webdb.pm #モデル (DB CONNECT とか…)

package Tool::Model::Webdb;
use Mojo::Base 'Mojolicious';
use DBI;
use utf8;
use Data::Dumper;
use Tool::Model::Webdb::constant;

has const => sub {
    my $s = shift;
    return Webdb::constant->new();  # constant dataを読み込む
};

has dbh => sub {
  my $self = shift;

  my $data_source = $self->const->{data_source};
  my $user        = $self->const->{user};
  my $password    = $self->const->{password};

  my $dbh = DBI->connect(
     $data_source,
     $user,
     $password,
     {RaiseError => 1,
      mysql_enable_utf8 =>1,
      mysql_auto_reconnect =>1,    # 再接続させる
     }
  );
  $dbh->do("set names UTF8");
  return $dbh;
};

sub desc_table{
  my $s = shift;
  my $m = shift || 'm';
  my $f;
  $s->{'m'}->{key} = [];
  $s->{'m'}->{item} = [];
  my $dbh = $s->dbh;
  my $sth = $dbh->prepare($s->desc_param($m));
  $sth->execute();
  my $flag = 0;
  while(my $ref = $sth->fetchrow_hashref()){
       $f = $ref->{Field};
       $s->{'m'}->{$f}->{Type} = $ref->{Type};
       $s->{'m'}->{$f}->{Null} = $ref->{Null};
       $s->{'m'}->{$f}->{Key} = $ref->{Key};
       $s->{'m'}->{$f}->{Default} = $ref->{Default};
       $s->{'m'}->{$f}->{Extra} = $ref->{Extra};
       $s->{'m'}->{$f}->{Size} = $s->size($ref->{Type});
       if($ref->{Key} eq 'PRI'){
           push @{$s->{'m'}->{key}},$f;
       }elsif($ref->{Type} =~ /timestamp/){
           $s->{'m'}->{timestamp} = $f;
       }else{  push @{$s->{'m'}->{item}},$f;
       }
       $flag = 1;
   }
   $sth->finish();
   return $s->{'m'};
}
sub size { . . . }
 .
 .
1;

lib/Tool/Model/Webdb/constant.pm # コンスタントデータ

package Webdb::constant;
use utf8;

sub new {
    my $class = shift;
    my $self = bless {},$class;
    $self->_initalize;
    return $self;
}
sub _initalize{
    my $s = shift;
    $s->{data_source} = "DBI:mysql:database=YourDB;host=localhost";
    $s->{user}        = "YourName";
    $s->{password}    = "YourPassword";

    $s->{explan} = {                            # DB項目の説明
        '担当者'    => {                        #   TABLE NAME
            'ID'    => 'admin:管理者,0~999',   #    FIELD NAME => COMMENT
        },
        '商品'      => {
            '商品区分' => '0:課税,1:非課税,2:軽減課税',
        },
    };
}

1;

lib/Tool/mmt/Mmt.pm # controller

package Tool::mmt::Mmt;
use Mojo::Base 'Mojolicious::Controller';
use Mojo::Log;
use utf8;
use Encode;
use Text::CSV::Encoded;

has 'mmtForm' => 'mmt/mainform';
has 'mmtDataList' => 'mmt/datalist';

# This action will render a template
sub mainform {
    my $self = shift;

    $self->{'m'} = $self->app->model->webdb->desc_table($self->param('_table'));      # model 呼び出し
    $self->{'m'}->{'table'} = $self->param('_table');
    $self->set_input_names();
    $self->action_set();

    $self->my_render($self->mmtForm);
}
sub my_render{
    my $s = shift;
    my $render = shift;
    $s->stash->{_title} = join('',$s->param('_table'));
    $s->render($render);
}
sub registry{
   my $self = shift;

   $self->action_set();
   my $log = Mojo::Log->new();
   $log->debug( "IN registry" );

   for my $action  (@{$self->{'_action'}}) {
       if($action->{'name'} eq $self->param('_action')){
           return $action->{action}();
       }
   }
   $self->stash->{'_dumper'} = $self->dumper ($self->param()) .
       $self->param('_action');
   $self->render('mmt/dumper');
}
 .
 .
 .

templates/mmt/mainform.html.ep # データメンテナンス画面

% layout 'default';
% title "mmt - $_title " ;
<h1><%= $_title %></h1>

%= form_for url_for('_table'=> param('_table')) => (method => 'POST') => begin
<%= hidden_field timestamp => param('timestamp') %>
<%= hidden_field _table => param('_table') %>
<table>
% for my $item (@{$self->{'m'}->{'key'}}){
 <tr>
  <th><div id="<%= 'l_' . $self->{'n'}->{$item} %>"> <%= $self->Label($item) %></div></th>
  <td><%== $self->input_field($item) %>
      <%== $self->get_explan(param('_table'),$item) %></td>
  <td><div id="<%= 'd_' . $self->{'n'}->{$item} %>">
 </tr>
% }
</table>
%= submit_button $self->{'_action'}[0]->{'name'} ,id => '_action',name => '_action'
<%== $self->serch_input_field() %>
%= submit_button $self->{'_action'}[4]->{'name'} ,id => '_action',name => '_action'
%= submit_button $self->{'_action'}[6]->{'name'} ,id => '_action',name => '_action'
<br>
INFO:<%= $self->{errstr} %>
<hr>
<table>
% my $i = 0;
% for my $item (@{$self->{'m'}->{'item'}}){
 <tr>
  <th><div id="<%= 'l_' . $self->{'n'}->{$item} %>"> <%= $self->Label($item) %></div></th>
  <td><%== $self->input_field($item) %>
      <%== $self->get_explan(param('_table'),$item) %></td>
  <td><div id="<%= 'd_' . $self->{'n'}->{$item} %>"></div></td>
 </tr>
% }
</table>

% for my $item (@{$self->{'_action'}}[1..3]){
%= submit_button $item->{'name'} ,id => '_action',name => '_action'
%  }
% end
<hr>
<form method="post" action="<%= url_for('_table'=> param('_table')) %>"
            enctype ="multipart/form-data">

        <input type="file" name="upload_file" />
        <%= hidden_field _table => param('_table') %>
        <input type="submit" value="Upload" name="_action" />
</form>

templates/mmt/datalist.html.ep # 一覧表示画面

% layout 'default';
% title "mmt - $_title";
<h1><%= $_title %></h1>
<table><tr><th></th>
% for my $item (@{$self->{'m'}->{'key'}},@{$self->{'m'}->{'item'}}){
  <th><div id="<%= $item %>"> <%= $self->Label($item) %></div></th>
% }
</tr>
% my $count = 0;
% while (my $ref = $self->{'sth'}->fetchrow_hashref()){
%   $count++;
%   last if $count > 2000;
<tr>
%= form_for url_for('_table'=> param('_table')) => (method => 'POST') => begin
<%= hidden_field _table => param('_table') %>
    <td>
    %= submit_button $self->{'_action'}[0]->{'name'} ,id => '_action',name => '_action'
    </td>
%   for my $name (@{$self->{'m'}->{key}}){
        <td><%= $ref->{Encode::encode("utf8",$name)} %>
        <%= hidden_field $self->{'n'}->{$name} => $ref->{Encode::encode("utf8",$name)} %>
        </td>
%   }
%   for my $name (@{$self->{'m'}->{item}}){
        <td><%= $ref->{Encode::encode("utf8",$name)} %></td>
%   }
% end
</tr>
% }
</table>
%=   "* No Data *" if ($count == 0);
%=   "* Max over * " if ($count > 2000);

templates/mmt/Commodity.pm # Mmtを継承したアプリケーション

package Tool::mmt::Commodity;
use Mojo::Base 'Tool::mmt::Mmt';

has 'mmtDataList' => 'mmt/datalist';

sub init_set {
    my $s = shift;
    $s->mmtForm('mmt/mainform');
    $s->param('_table','商品');
}
sub look_up_set{
    my $s = shift;
    $s->{'m'}->{LOOK_UP}->{ref $s}->{$s->{'n'}->{'大分類'}} = 
        ["select 略称 from 分類名称 where 中分類 = '' and 小分類 = '' and 大分類 = ? ", 
            [$s->{'n'}->{'大分類'}] ];
    $s->{'m'}->{SUBWIN}->{ref $s}->{$s->{'n'}->{'大分類'}} = 
        ["select 大分類,略称 from 分類名称 where 中分類 = '' and 小分類 = ''", 
             []];

    $s->{'m'}->{LOOK_UP}->{ref $s}->{$s->{'n'}->{'中分類'}} = 
        ["select 略称 from 分類名称 where 大分類 = ? and 中分類 = ? and 小分類 = '' ", 
            [$s->{'n'}->{'大分類'},$s->{'n'}->{'中分類'}] ];
    $s->{'m'}->{SUBWIN}->{ref $s}->{$s->{'n'}->{'中分類'}} = 
        ["select 中分類,略称 from 分類名称 where 大分類 = ? and 中分類 <> '' and 小分類 = ''", 
            [$s->{'n'}->{'大分類'}] ];

    $s->{'m'}->{LOOK_UP}->{ref $s}->{$s->{'n'}->{'小分類'}} = 
        ["select 略称 from 分類名称 where 大分類 = ? and 中分類 = ? and 小分類 = ? ", 
            [$s->{'n'}->{'大分類'},$s->{'n'}->{'中分類'},$s->{'n'}->{'小分類'}] ];
    $s->{'m'}->{SUBWIN}->{ref $s}->{$s->{'n'}->{'小分類'}} = 
        ["select 小分類,略称 from 分類名称 where 大分類 = ? and 中分類 = ? and 小分類 <> ''", 
            [$s->{'n'}->{'大分類'},$s->{'n'}->{'中分類'}] ];
}

1;

TODO

  • validation
  • 検索SUB画面 (1/7)
  • 綺麗な画面
  • ENTERで項目移動 (12/9)
  • セッション管理
  • login処理
  • メニュー作成
  • レポートライターツール

ENTERで項目移動 (12/9)

[toolmmt/templates/layouts/toolmmt/templates/layouts]
 <!DOCTYPE html>
 <html>
   <head><title><%= title %></title>
    <script src="http://ajax.googleapis.com/ajax/libs/jquery/1.7/jquery.min.js"></script>
      <script type="text/javascript">  <!-- [jQuery] Enterキーでフォーカスを移動するには http://blog.makotoishida.com/2013/02/javascript-enter.html -->
             $(function(){
               var elements = "input[type=text]";
               $(elements).keypress(function(e) {
                 var c = e.which ? e.which : e.keyCode;
                 if (c == 13) { 
                   var index = $(elements).index(this);
                   var criteria = e.shiftKey ? ":lt(" + index + "):last" : ":gt(" + index + "):first";
                   $(elements + criteria).focus();
                   e.preventDefault();
                 }
               });
             });
      </script>
   </head>
   <body><%= content %></body>
 </html>

ajaxにてテーブル参照とサブウインドを開く

 sub make_ajax{
     my $s = shift;
     my $p = '';
     my $onload = '';
     #
     # マスタ参照ajax(LOOK_UPをサーチ)
     #
     for (keys %{$s->{'m'}->{LOOK_UP}->{ref $s}}){
         next unless ($_ =~ /^(\D)+(\d)+$/);
         $p .= $s->new_updater($_);
         $onload .= "\$('#$_').change();\n";
     }
     #
     # マスタ参照ウインド(WUBWINをサーチ)
     #
     for (keys %{$s->{'m'}->{SUBWIN}->{ref $s}}){
         next unless ($_ =~ /^(\D)+(\d)+$/);
         $p .= $s->new_subwin($_);
     }
     return $p . $onload;
 }
 #
 # マスタ参照(http://www21051ue.sakura.ne.jp:3003/mmtx/commodity?_action=get_name&n=item5&p=001&p=002)
 #
 sub get_name{
     my $s = shift;
     my @names = qw/未登録/;
     #eval {
         @names = $s->app->model->webdb->dbh->selectrow_array(
                     $s->{'m'}->{LOOK_UP}->{ref $s}->{$s->param('n')}->[0],undef,$s->param('p'));
     #};
     if ($@){
         $s->render(json=>$@);
     } else{
         my $json = {rec=>@names};
         $s->render(json=>$json);        # JSONを描画する
     }
 }
 sub subwin{
     my $s = shift;
     my $subwin = $s->{'m'}->{SUBWIN}->{ref $s}->{$s->param('n')};
     my $sql = $subwin->[0];
     my $render = $subwin->[2] || 'mmt/subwin';
     my $param = $s->param('p');
     my $dbh = $s->app->model->webdb->dbh;
     $s->{'sth'} = $dbh->prepare($sql);
     $s->{'sth'}->execute($s->param('p'));
     $s->stash->{_title} = '検索';
     $s->stash->{_sql} = $sql;
     $s->stash->{_controller} = ref $s;
     $s->render($render);
 }
 sub new_updater{
     my $s = shift;
     my $n = shift;
     my $p = '"';
     $p .= join '',map{qq{ + "&p=" + \$('#$_').val()}} @{$s->{'m'}->{'LOOK_UP'}->{ref $s}->{$n}->[1]};
     return <<End_Script;
 jQuery('#$n').change( function (){                  // 内容が変化した時に実行
     jQuery.ajax({                                   // http通信を行う
      type: 'GET',                                   // 通信種類を指定(GET,POST,PUT,DELETE)
      dataType: 'json',                              // サーバーから返されるデータタイプ
      data: "_action=get_name&n=$n$p ,               // サーバーに送信する値
      success:function(data,textStatus,jqXHR){       // ajax通信が成功した時のajax event
       jQuery('#d_$n').html(data.rec);               // 返値を描画
      return false;
      }
     });
 });
 End_Script
 }
 sub new_subwin{
     my $s = shift;
     my $n = shift;
     my $p = '"';
     $p .= join '',map{qq{ + "&p=" +  \$('#$_').val()}} @{$s->{'m'}->{'SUBWIN'}->{ref $s}->{$n}->[1]};
     my $win_para = "width=600,height=500,resizable=yes,scrollbars=yes";
     return <<End_Script;
 jQuery(document).ready(function(){                  
     jQuery('#l_$n').html(                           // LABELをボタンに変更する
         "<input type=button value=@{[$s->Label($s->get_input_name($n))]}>");
 });
 
 jQuery('#l_$n').click( function (){                 // SUB WINDOWを開く
     window.open("@{[$s->url_for->query(            
                         _action=>'subwin'
                         ,n=>$n
                         )
                   ]}$p,'_blank','$win_para');
     return false;
 });
 End_Script
 }
 
 1;

SUB WINDOW

[layouts/defsubwin.html.ep]
<!DOCTYPE html>
<html>
  <head><title><%= title %></title>
   <script src="http://ajax.googleapis.com/ajax/libs/jquery/1.7/jquery.min.js"></script>
     <script type="text/javascript">  <!-- [jQuery] Enterキーでフォーカスを移動するには http://blog.makotoishida.com/2013/02/javascript-enter.html -->
            $(function(){
              var elements = "input[type=text]";
              $(elements).keypress(function(e) {
                var c = e.which ? e.which : e.keyCode;
                if (c == 13) { 
                  var index = $(elements).index(this);
                  var criteria = e.shiftKey ? ":lt(" + index + "):last" : ":gt(" + index + "):first";
                  $(elements + criteria).focus();
                  e.preventDefault();
                }
              });
            });
            function setVal(terget,val){
                window.opener.$("#"+terget).val(val);           // 選択値を親画面にセットする
                window.opener.$("#"+terget).change();           // changeイベントを発生する
                window.opener.$("#"+terget).focus();            // フォーカスを移動する
                window.close();                                 // 自ウィンドを閉じる
            }
     </script>
     <%= stylesheet '/css/default.css' %>
  </head>
  <body>
    <div class="subwin">
      <%= content %>
    </div>
  </body>
</html>
[mmt/subwin.html.ep]
% layout 'defsubwin';
% title "mmt - $_title";
<h1><%= $_title %></h1>
<%= $_sql %><br />
[<%= $_controller %>][<%= param('n') %>][<%= join '|',param('p') %>]
<table border=1><thead><tr>
% for my $item (@{$self->{'sth'}->{'NAME'}}){
  <th><div id="<%= $item %>"> <%= Encode::decode('UTF-8',$item) %></div></th>
% }
</tr>
</thead>
<tbody>
% my $count = 0;
% while (my $ref = $self->{'sth'}->fetchrow_arrayref()){
%   $count++;
%   last if $count > 2000;
<tr>
%   my $i = 0;
%   for my $item (@{$ref}){
%       $i++;
        <td>
%       if($i == 1){
            <a href="" onclick="setVal('<%= param('n') %>','<%= $item %>');">
%       }
        <%= $item %></td>
%   }
</tr>
% }
</tbody>
</table>
%=   "* No Data *" if ($count == 0);
%=   "* Max over * " if ($count > 2000); 

gitbash

gitbash

これだけあればwindowsを使うのが楽しくなる。

ここhttps://git-for-windows.github.io/からダウンロード

gitは使わないが(まだ)これをインストールすればwindowsbash,vim,perlが使える。windowsで*nixLIKEのオペレーションが…

日本語の設定 .profileを編集 (vim .profile)

cat .profile
export LANG=ja_JP.UTF8
export PS1="$ "

これで十分