perl memo
https://github.com/hatena/Hatena-Textbook
perldoc.jp
フリップフロップ演算子
あるファイルの20行目〜30行目まで抜き出すときは
$ perl -ne ‘print if (20 .. 30);’ file
ファイルからタイトルを抜き出そうとしたとき
$ perl -ne 'print if (/<title>/.. /<\/title>/);' a.html
開始条件と終了条件が同時にtrueになったときにはそこで終了されたら困るようなときというのがある。そんな場合には、「…」を使います。
たとえば、開始マークと終了マークに挟まっているのではなくて、ただ切れ目だけがわかるようなファイル。
$ perl -ne 'print if (/<hr>/ ... /<hr>/);' bbs_log
入れ子を許した括弧内にマッチさせる
http://www.din.or.jp/~ohzaki/regex.htm#GetNestedParen より
$openclose = qr/\([^()]*(?:(??{$openclose})[^()]*)*\)/;
while ($str =~ /($openclose)/g) {
print $1, "\n";
}
javascriptのテキストより関数を取り出す。
sub useFunc{
my $s = shift;
my $func = shift;
my $javascript = $s->formScript();
#my $openclose = qr/\{[^{}]*(?:(??{$openclose})[^{}]*)*\}/;
#$javascript =~ /(function\s+$func\s*\([^)]*\)$openclose)/;
$javascript =~ /(function\s+$func\s*\([^)]*\)(\{(?:(?>[^\{\}]+)|(?2))*\}))/;
return $1;
}
記号だけのperlプログラム
「はろーわーるど！」と表示 http://perl-users.jp/articles/advent-calendar/2010/sym/12 より
$ perl -Mre=eval -e "''=~(('(').((''=='').''^'^'^'~'^'.').((''=='').''^'='^'^'^')').('^'^'.').('='^'~'^(''=='').'').('('^'^'^'.'^(''=='').'').('('^'^'^')'^(''=='').'').('~'^'('^'='^(''=='').''^'.').((''=='').''^'='^'.').~('~'^'^'^'('^')'^'=').~('~').~('.'^'~').~('^'^'('^'~'^'='^')').~('.'^'='^'('^'^'^')'^(''=='').'').~((''=='').''^'~'^'=').~('='^'('^')'^'^'^'~').~('.'^'^'^'='^(''=='').'').~('='^'~').~('^'^'~'^')'^'='^'(').~((''=='').''^'='^')'^'('^'^'^'.').~('^'^'.').~('^'^'='^')'^'~'^'(').~('^'^'.'^(''=='').''^'=').~('~'^'=').~('='^'^'^'~'^')'^'(').~(')'^'^'^'.'^'('^(''=='').''^'=').~('~'^'.'^(''=='').''^'='^'(').~('~'^'='^')'^'^'^'(').~('~').~('('^'~').~(')'^'^'^'('^'~'^(''=='').'').~('='^'~').~('~').('('^'.'^(''=='').''^'=').('.'^(''=='').''^'=').((''=='').''^')'^'.'^'='^'('^'^').(')'))"
Hello world! と表示
$ perl -Mre=eval -e "''=~('(?{'.('[[).[|\`%,,/\`[/[@$'^'+)@@/^(@@@@@,@),@').'! \"})')"
use re 'eval';しないとエラーとなる
シンタックスハイライト
少しお洒落なソースファイルを貼る時に便利なパールモジュール Text::VimColor使い方はとっても簡単。内部でvimを呼んでるらしい。cssはlight.cssが同梱されてます。
use Text::VimColor;
:
:
print start_html(-title=>"@{[$in->param('file')]}",
-style=>[{'src'=>'css/light.css'}],
-head=> $in->meta({ -http_equiv => 'Content-Type',-content => "text/html; charset=$charset" }));
:
:
open(FILE,"<:utf8","@{[$in->param('file')]}");
{ local $/ = undef;
my $text = <FILE>;
print Text::VimColor->new(filetype=>'perl',string=>$text)->html;
}
:
:
与えられた数値以下の最大の素数を探す
$ perl -E 'sub f{$x=pop;for(2..sqrt($x)){if ($x%$_==0){ return $_}}return 0} while(f($d|=pop)){$d--}say $d' 100
SQLite
$ perl -MDBI -MData::Dumper -e 'print Dumper (DBI->connect(q{DBI:SQLite:dbname=d:/mfrdata/server.db})->selectall_arrayref(q{pragma table_info("TableName")},+{Slice=> +{}}))'
$ perl -MDBI -MData::Dumper -e 'print Dumper (DBI->connect(q{DBI:SQLite:dbname=d:/mfrdata/server.db})->selectall_arrayref(q{select name from sqlite_master where type = "table"},+{Slice=> +{}}))'
web server
ウェーブサーバーみたいな物を作ってみた。
HTTP::DaemonのMulti-PartレスポンスをCGI.pmでパースする方法が解らなかったので手でパースしてしまった。
package myapp;
{
use strict;
use base qw(HTTP::Response);
use HTTP::Status;
use DBI;
use IO::String;
use CGI;
use Data::Dumper;
my $PUBLIC = q{public};
sub router {
my ($s,$c,$r) = @_;
$s->init($c,$r);
if ($r->method eq 'GET'){
if($r->url->path =~ /\/(.+\.cgi\.*)/){
$s->post($c,$r);
}
elsif($r->url->path =~ /\/(.+\..+)/){
$c->send_file_response("$PUBLIC/$1");
}
}
elsif ($r->method eq 'POST'){
$s->post($c,$r);
}
else {
$c->send_error(RC_FORBIDDEN);
}
}
sub post {
my ($s,$c,$r) = @_;
$c->send_response;
print $c "<html><body><pre>";
print $c (Dumper $r);
print $c "-" x 80 . "\n";
for($s->{cgi}->param){
print $c "[$_] => [" . $s->{cgi}->param($_) . "]\n";
}
print $c "</pre>";
print $c "</body></html>";
}
sub init{
my ($s,$c,$r) = @_;
my $form_parameters = $r->uri;
if($form_parameters =~ /^.*\?(.+)/){
$form_parameters = $1 . "&";
}
else{
$form_parameters = q{};
}
$form_parameters .= $r->content;
if($r->content =~ /^--/){
my ($boundary) = split(/\n/, $form_parameters); chop($boundary);
# substr($boundary, 0, 2) = ''; # delete the leading "--" !!!
$ENV{'CONTENT_TYPE'} = $r->content_type . "; boundary=$boundary";
$ENV{'CONTENT_TYPE'} = $r->{_headers}->{'content-type'};
$ENV{'CONTENT_LENGTH'} = $r->content_length;
close STDIN; my $t = tie *STDIN, 'IO::String';
$t->open($form_parameters);
local $| = 1;
$s->{cgi} = CGI->new();
local $/ = "\r\n";
my @param = split($boundary,$r->content);
for(@param){
if(/\sname="([^"]+)"/){
my $name = $1;
my ($head,$body) = split("\r\n\r\n",$_);
chomp($body);
$body =~ s/$boundary//;
$s->{cgi}->param($name,$body);
}
}
}
else{
$s->{cgi} = CGI->new($form_parameters);
}
}
}
1;
package main;
use strict;
use HTTP::Daemon;
use POSIX ":sys_wait_h";
sub REAPER {
$SIG{CHLD} = \&PEAPER;
while (my $pid = waitpid(-1,WNOHANG)) {
print "End $pid \n";
}
}
#$SIG{CHLD} = \&PEAPER;
$SIG{CHLD} = 'IGNORE';
my $pid;
my $d = HTTP::Daemon->new(
LocalPort => 8888,
) || die;
print "Please contact me at: <URL:", $d->url, ">\n";
my $app = myapp->new();
while (1){
my $c = $d->accept;
if (!defined($pid = fork)) {
die "can't fork:$!\n";
}
elsif ($pid) {
}
else {
$d->close;
while (my $r = $c->get_request) {
$app->router($c,$r);
}
$c->close;
undef($c);
exit();
}
$c->close;
undef($c);
}
ハノイの塔を解く
AからCへ数枚の円盤を移動する
use strict;
hanoi(pop,"A".."C",sub {print qq{@{[++$a]}: $_[1]($_[0])=>$_[3]\n}});
sub hanoi{
return unless($_[0]);
push(@_,$_[0]-1);
hanoi(@_[-1,1,3,2,4]);
$_[4]->(@_);
hanoi(@_[-1,2,1,3,4]);
}
$ perl hanoi.pl 4 1: A(1)=>B 2: A(2)=>C 3: B(1)=>C 4: A(3)=>B 5: C(1)=>A 6: C(2)=>B 7: A(1)=>B 8: A(4)=>C 9: B(1)=>C 10: B(2)=>A 11: C(1)=>A 12: B(3)=>C 13: A(1)=>B 14: A(2)=>C 15: B(1)=>C $
terminalでハノイの塔を表示する
use strict;
my $n = shift;
my @towers = ('A' .. 'C');
my $hanoi_towers->{$towers[0]} = [ reverse ( 1 .. $n ) ];
print "\e[2J";
hanoi_print($hanoi_towers);
hanoi($n,@towers,sub {
push(@{$hanoi_towers->{$_[3]}},pop(@{$hanoi_towers->{$_[1]}}));
hanoi_print($hanoi_towers);
});
sub hanoi{
return unless($_[0]);
push(@_,$_[0]-1);
hanoi(@_[-1,1,3,2,4]);
$_[4]->(@_);
hanoi(@_[-1,2,1,3,4]);
}
sub hanoi_print{
my $t = shift;
local $| = 1;
select(undef,undef,undef,0.3);
print "\e[1;1H";
map { printf (" %2s %2s %2s\n",p2($t,$_))} (reverse (0 ..$n));
printf (" %2s %2s %2s\n","-","-","-");
printf (" %2s %2s %2s\n",@towers);
print "\n";
}
sub p2{
my ($t,$i) = @_;
return map {$t->{$_}->[$i] ? $t->{$_}->[$i] : ' '} @towers;
}
One Liner
モンテカルロ法で円周率を求めるワンライナー すぎゃんめもより
$ perl -lE 'for $i (1 .. pop){rand()**2+rand()**2 <=1 &&$x++; $i=~/^1[0]+$/ && say "$i,@{[$x*4/$i]}"}' 10000000
10,3.2
100,3.16
1000,3.164
10000,3.154
100000,3.13716
1000000,3.142384
10000000,3.1422264
$ perl -lE 'for $i (1 .. pop){rand()**2+rand()**2 <=1 &&$x++; $i=~/^1[0]+$/ && say "$i,@{[$x*4/$i]}"}' 10000000
10,2.8
100,3.24
1000,3.22
10000,3.1776
100000,3.15128
1000000,3.141972
10000000,3.1414164
$
ハノイの塔
perl -E 'sub h{return if(!$_[0]);push(@_,$_[0]-1);h(@_[-1,1,3,2,4]);$_[4]->(@_);h(@_[-1,2,1,3,4]);} h(pop,A..C,sub {say "$_[1]($_[0])=>$_[3]";})' 3
Oracle select
perl -MDBI -MData::Dumper -e "print Dumper (DBI->connect(q{dbi:Oracle:olcl},q{userName},q{password})->selectall_arrayref(q{select * from tabs where rownum < 5},+{Slice => +{}}));"
その他
perl -e "for my $i (glob(q{*019*})){ my $o; ($o = $i) =~ s/019/024/; rename($i,$o);}"
perl -MFile::Copy -e "my $i = q{InFile.xls}; for my $c (1 .. 100){ my $o; $c = sprintf(q{%03d},$c);($o = $i) =~ s/\d+/$c/; copy($i,$o) or die qq{copy($i,$o):$!}}"
ディレクトリ下の行数
$ 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
$
Win32::OLE (2014/10/31)
windowsでexcelを更新する
> perl excel_upd.pl A10 2014/10/31 xxxxxx.xls
--- ---------- ----------
| | |
| | +------- 更新対象excel
| +----------------- 更新内容
+--------------------------- 更新対象セル
[excelt_upd.pl]
use strict;
use Win32::OLE;
my ($cel,$value) = ($ARGV[0],$ARGV[1]);
for my $filename (glob($ARGV[2])) {
print "[$filename]\n";
excel_update($filename);
}
sub excel_update{
my $file = shift;
my $oBook = Win32::OLE->GetObject($file,sub {$_[0]->Quit;}) or die "$file:$!";
$oBook->Windows(1)->{Visible} = 1; # 次にexcelを開いたときに表示される様に
my $oSheet = $oBook->Worksheets(1);
$oSheet->range($cel)->{Value} = $value;
$oBook->Save();
$oBook->Close();
}
WebSocket
僕の車輪の再発明で教えてもらったmojoliciousのwebsocketチャットを作ってみた。（写経しただけ。感謝!!)ubuntuのChrome、Fierfox、androidのChromeで動く事を確認しました。すごいねperl(mojolicious)。今度はチャボをwebsocket対応にしよう。[2014/4/14]チャボとお話出きるようになりました。
#!/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';
my $clients = {};
websocket '/echo' => sub {
my $self = shift;
Mojo::IOLoop->stream($self->tx->connection)->timeout(600);
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 $txt = '';
if($ans =~ m|<answer>(.*)</answer>|){
$txt = decode('UTF-8',$1);
}
# チャボに話しかける --- 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');
};
var ws = new WebSocket('<%= url_for('/echo')->to_abs->scheme('ws'); %>');
ws.onopen = function () {
log('Connection opened');
};
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>
ここでの発言はチャボに記憶され何処かで引用される可能性が
有ります。ご注意下さい。
<textarea id="log" readonly></textarea>
<p>name<input type="text" id="name" /><br />msg<input type="text" id="msg" size="40"/></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: 40em;
height:10em;
}
</style>
</head>
<body><%= content %></body>
</html>
taro-nishinoの日記： 何故、私はJavaプログラマでないのか
何故、私はJavaプログラマでないのか
Michael G Schwern
始めに、はっきり言っておかなければならない。このエッセイは、何故私がJavaプログラマでないのか、一個人の理由と考察に関するものである。それは、何故貴方がJavaプログラマでないのか、ではない。また、何故PerlがJavaより優れているか、ではない。それはまた、何故Javaがそうなっている（私はほぼSunの設計方針により、そうなっているのを知っているが）のか、ではない。しかし、何故そうでないのか、理由を知ることは苛立ちを減らす。
.
.
"Hello World"は、一ステートメントであるべきである。
OOがすべてではない。
CPANが無い。
関数ポインターが無いことは、クロージャが無いことを意味する。
シンボルテーブルの操作が無い。
動的なメソッド生成が無い。
evalが無い。
多重継承が無い。
ヒアドキュメントが無い。
官僚的なプライバシールール。
強い型の強制。
.
.
.
結論。
Perlは簡潔な言語であり、アイデアをコードの中へ素早く簡単に投げるように設計されている。Javaは簡潔な文法で一貫性がある言語であり、よいスタイルを鼓舞し、組込み易く設計されている。どちらも強みと弱みを持っているが、人は滅多にどちらがどちらなのか一致しない。人はそのように可笑しいのである。或る者は、自分に制限を課して、自分自身から自分を救いたい。或る者は、出来るだけ制限を取り払い、自分自身になりたい。両者とも危険に満ちている。私は偶々後者の危険性を好んだのである。
Bjarne Stroustrupは以下のことを言ったことがある。
「我々が思考又はプログラミングする言語、問題、イメージ出来る解法の間の関係は非常に近い。この理由のため、プログラマのエラーを除去する特徴の言語を抑制することは結局危険である。」
しかし、Larry Wallはうまく要約していると私は思う。
「Perlで汚いプログラムを書くことが可能であるという事実はまた、明晰さを強要する言語で書けたであろうプログラムよりも明晰なプログラムをPerlで書くことが可能であるということである。とてもいいことをする潜在能力は、とても悪いことをする潜在能力ともに進む。」
object
package objchk;
use strict;
sub new{
my $class = shift;
my $o = {};
bless $o,$class;
$o->{SUB}->{sub} = sub {$o->sub1};
return $o;
}
sub action{
my $s = shift;
my $sub = shift || 'sub';
if (ref $s->{SUB}->{$sub} eq 'CODE'){
$s->{SUB}->{$sub}();
}else{
print "$sub : not CODE\n";
}
}
sub sub1{
my $s = shift;
print "sub1\n";
}
1;
#!/usr/local/bin/perl
use strict;
package myobj;
use base qw(objchk);
sub sub2{
my $s = shift;
for(keys %{$s->{SUB}}){
print "key : ",$_,"\n";
}
print "sub2\n";
}
sub sub3{
my $s = shift;
print "sub3\n";
}
sub sub4{
my $s = shift;
print ref $s->{SUB}->{sub4},"\n";
}
1;
package main;
my $o = myobj->new;
$o->{SUB}->{sub2} = sub {$o->sub2};
$o->{SUB}->{sub3} = sub {$o->sub3};
$o->{SUB}->{sub4} = sub {$o->sub4};
$o->action('sub3');
$o->action('sub2');
$o->action();
$o->action('sub5');
$o->{SUB}->{sub2} = sub {$o->sub3};
$o->action('sub2');
$o->action('sub4');
$ ./aa.pl sub3 key : sub4 key : sub key : sub2 key : sub3 sub2 sub1 sub5 : not CODE sub3 CODE $
test
$ prove t t/01webdb....ok All tests successful. Files=1, Tests=3, 0 wallclock secs ( 0.19 cusr + 0.01 csys = 0.20 CPU) $
$ ls t ;echo "[t/01webdb.t]";cat t/01webdb.t
01webdb.t*
[t/01webdb.t]
#!/usr/bin/perl
use strict;
use warnings;
use Test::More qw(no_plan);
use_ok('webdb');
my $o = webdb->new();
ok($o->random_str() =~ /^[\w]{8}$/, 'Random_str');
TODO: {
local $TODO = 'テストのやり方が解らない';
# ok($o->secure($o));
}
ok($o->login());
$
- 無精・短気・傲慢