2018-10-26

WebPerl

Welcome to WebPerl!

欲しかったやつ！！javascriptをperlで置き換えられる。

WebPerl uses the power of WebAssembly and Emscripten to let you run Perl 5 in the browser!
WebPerl does not translate your Perl code to JavaScript,
instead, it is a port of the perl binary to WebAssembly,
so that you have the full power of Perl at your disposal!

WebPerlは、WebAssemblyとEmscriptenの機能を使って、Perl 5をブラウザで実行できるようにします。WebPerlはあなたのPerlコードをJavaScriptに変換するのではなく、WebAssemblyへのperlバイナリのポートですので、自由にPerlの能力をフルに活用できます！

demo

[webperl_demo.html]

<!doctype html>
<html lang="en-us">
<head>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
<title>WebPerl &lt;script&gt; Demos</title>

<script src="webperl.js"></script>

<!-- Please see the documentation at http://webperl.zero-g.net/using.html -->

<!-- Example 1: A really basic script -->
<script type="text/perl">
print "Hello, Perl World!\n";
</script>

<!-- Example 2: Accessing JavaScript -->
<script type="text/perl">
use warnings;
use strict;
use WebPerl qw/js/;

js('document')->getElementById('my_button')
	->addEventListener("click", sub {
		print "You clicked 'Testing!'\n";
	} );

</script>

<!-- Example 3: Using jQuery -->
<script src="https://code.jquery.com/jquery-3.3.1.min.js" integrity="sha256-FgpCb/KJQlLNfOu91ta32o/NMZxltwRo8QtmkMRdAu8=" crossorigin="anonymous"></script>
<script type="text/perl">
use warnings;
use strict;
use WebPerl qw/js/;

my $jq = js('jQuery');
my $btn = $jq->('<button>', { text=>"Click me!" } );
$btn->click(sub {
	print "You clicked the jQuery button!\n";
} );
$btn->appendTo( $jq->('#buttons') );

# And a demo of AJAX using jQuery:
use Cpanel::JSON::XS qw/encode_json/;
use Data::Dumper;
my $data_out = { hello => "Hello, World!\n" };
$jq->ajax( '/ajaxtest', {
	method => 'POST', # we're sending JSON in the POST body
	data => encode_json($data_out),
} )->done( sub {
	my $data_in = shift;
	print "AJAX Success! Data: ", Dumper($data_in->toperl);
} )->fail( sub {
	my ($jqXHR, $textStatus, $errorThrown) = @_;
	print "AJAX Failed! ($errorThrown)\n";
} );

</script>

<!-- Optional STDOUT/STDERR text area (if you don't use this, output goes to Javascript console) -->
<script>
window.addEventListener("load", function () {
	document.getElementById('output')
		.appendChild( Perl.makeOutputTextarea() );
});
</script>

</head>
<body>

<p>This is a demo of <a href="http://webperl.zero-g.net" target="_blank">WebPerl</a>!</p>

<div id="output"></div>
<div id="buttons">
	<button id="my_button">Testing!</button>
</div>

</body>
</html>

2018-04-18

B-TREE

B-TREEの考察

B-TREEを理解する為にviz3/btree.c(c)をperlに写経してみた。とりえず動く物を作ってから考えようと。【デモ】←クリック

sub btree{
    my $s = shift;
    $s->M(int(rand(8)+2));
    $s->debugtext($s->debugtext . " (M:" . $s->M . ")"); 
    $s->insert($_ * 2) for (11 .. 15);
    $s->insert($_ * 2 - 1) for (1 .. 6);
    $s->insert($_) for (1 .. 20);
    $s->insert($_) for (30 .. 100);
    $s->insert(7);
    $s->delete($_) for (92 .. 99);
    $s->delete(11);
    $s->delete(51);
    $s->insert(11);
    $s->insert(51);
    $s->delete(75);

    $s->level(0);
    $s->tree_dump($s->root);
    $s->render(template => 'btree/btree','message'=> $s->message,
           'treetext'=>$s->debugtext);
}

wikiより

B木

B木（びーき）は、コンピュータサイエンスにおけるデータ構造、特に木構造の一つ。ブロック単位のランダムアクセスが可能な補助記憶装置（ハードディスクドライブなど）上に木構造を実装するのに適した構造として知られる。実システムでも多用されており、データベース管理システムの多くはB木による索引を実装している（B木の改良型または亜種であるB+木やB*木を使うことが多い）。

構造

多分岐の平衡木(バランス木)である。1 ノードから最大 m 個の枝が出るとき、これをオーダー m のB木という。後述する手順に従って操作すると、根と葉を除く「内部ノード」は最低でも m /2 の枝を持つことを保証できる。各ノードは、枝の数 - 1 のキーを持つ。枝1 ～枝m とキー1 ～キーm -1 を持つとき、枝i にはキーi -1 より大きくキーi より小さいキーだけを保持する（キーの重複を許す場合はどちらかに等号をつける）。葉ノードの定義は文献によって違いが見られる。木の終端をヌルポインタのような特殊な値で表す場合、枝がすべて終端記号となっているノードを葉とする。これに対して一部の文献では、終端を表すためにキーが0個のノードを連結し、このノードを葉と定義している。すなわち、後者の定義における葉ノードの親が、前者の定義における葉ノードとなる。後者の定義をとる文献では「葉ノードはキーを持たない」ということになる。以下の記述では、前者の定義に従うものとする。ノードはページと呼ばれることもある。特にハードディスクドライブなどの外部記憶装置を使ってB木を実現する場合によく見られる。この場合、各ノード（ページ）のサイズが、外部記憶装置のブロックサイズの整数倍になるようにオーダーを調整することが多い。B木の中でも特に、オーダー3のものを2-3木、オーダー4のものを2-3-4木と呼ぶ。

B-TREE

B-TREE

削除しました
Debug TREE (M:9)
N -> 7ー [ 10, 20, 35, 45, 55, 65, 76 ]
N -> 9ーー [ 1, 2, 3, 4, 5, 6, 7, 8, 9 ]
N -> 9ーー [ 11, 12, 13, 14, 15, 16, 17, 18, 19 ]
N -> 9ーー [ 22, 24, 26, 28, 30, 31, 32, 33, 34 ]
N -> 9ーー [ 36, 37, 38, 39, 40, 41, 42, 43, 44 ]
N -> 9ーー [ 46, 47, 48, 49, 50, 51, 52, 53, 54 ]
N -> 9ーー [ 56, 57, 58, 59, 60, 61, 62, 63, 64 ]
N -> 9ーー [ 66, 67, 68, 69, 70, 71, 72, 73, 74 ]
N -> 16ーー [ 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 100 ]

2018-04-18

B-TREE

B-TREEの考察

B-TREEを理解する為にviz3/btree.c(c)をperlに写経してみた。とりえず動く物を作ってから考えようと。【デモ】←クリック

sub btree{
    my $s = shift;
    $s->M(int(rand(8)+2));
    $s->debugtext($s->debugtext . " (M:" . $s->M . ")"); 
    $s->insert($_ * 2) for (11 .. 15);
    $s->insert($_ * 2 - 1) for (1 .. 6);
    $s->insert($_) for (1 .. 20);
    $s->insert($_) for (30 .. 100);
    $s->insert(7);
    $s->delete($_) for (92 .. 99);
    $s->delete(11);
    $s->delete(51);
    $s->insert(11);
    $s->insert(51);
    $s->delete(75);

    $s->level(0);
    $s->tree_dump($s->root);
    $s->render(template => 'btree/btree','message'=> $s->message,
           'treetext'=>$s->debugtext);
}

wikiより

B木

構造

B-TREE

B-TREE

削除しました
Debug TREE (M:9)
N -> 7ー [ 10, 20, 35, 45, 55, 65, 76 ]
N -> 9ーー [ 1, 2, 3, 4, 5, 6, 7, 8, 9 ]
N -> 9ーー [ 11, 12, 13, 14, 15, 16, 17, 18, 19 ]
N -> 9ーー [ 22, 24, 26, 28, 30, 31, 32, 33, 34 ]
N -> 9ーー [ 36, 37, 38, 39, 40, 41, 42, 43, 44 ]
N -> 9ーー [ 46, 47, 48, 49, 50, 51, 52, 53, 54 ]
N -> 9ーー [ 56, 57, 58, 59, 60, 61, 62, 63, 64 ]
N -> 9ーー [ 66, 67, 68, 69, 70, 71, 72, 73, 74 ]
N -> 16ーー [ 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 100 ]

2017-11-23

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;
}

マルコフ連鎖

編集

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

サンプル(適当に喋る)

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();

  // １番下にスクロールする -- START
  var go_bottom = function(targetId){
    var $obj = $("#" + targetId);
    if ($obj.length == 0) return;
    $obj.scrollTop($obj[0].scrollHeight);
  };
  // １番下にスクロールする -- 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>

2017-10-11

JSONP

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

ただ、外部サービスと通信する際に、AjaxでJSONをやり取りするには「クロスドメイン」という壁があります。つまり、他ドメインに属するファイルは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;

2016-07-02

mojolicious memo

perl WAF

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

起動

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

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

mojoliciousでJSONをPOSTで送信と受信

HTMLファイルからPOSTでJSONデータを送信する(http://qiita.com/kidatti/items/21cc5c5154dbbb1aa27f )より

デモ画面を作ってみた。

[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']);

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

yuki-kimoto/mojolicious-guides-japaneseより

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

 # /           -> {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で作ったアプリ

2016-05-10

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

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.要素が演算子の場合にスタックから２つの要素を取出し計算結果をスタックに積む。
                                                                       # 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;
}

無精・短気・傲慢

perlの事いろいろ

WebPerl

Welcome to WebPerl!

B-TREE

B-TREEの考察

wikiより

B木

構造

B-TREE

B-TREEの考察

wikiより

B木

構造

chabo - AI(Artificial incompetence)

リファクタ

mecab

マルコフ連鎖

ソース

JSONP

JSONP

仕組

注意点

サンプル

mojolicious memo

perl WAF

mojoliciousでJSONをPOSTで送信と受信

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

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

mojoliciousで作ったアプリ

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

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

使い方

[calc.pl]