https://github.com/hatena/Hatena-Textbook
!perldoc.jp
*[perlootut - Perl でのオブジェクト指向プログラミングのチュートリアル|https://perldoc.jp/docs/perl/5.16.1/perlootut.pod]
*[perlobj - Perl オブジェクトのリファレンス|https://perldoc.jp/docs/perl/5.32.0/perlobj.pod]
!フリップフロップ演算子
あるファイルの20行目〜30行目まで抜き出すときは
$ perl -ne ‘print if (20 .. 30);’ file
ファイルからタイトルを抜き出そうとしたとき
$ perl -ne 'print if (//.. /<\/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;
}
:
:
{{ref_image vimcolor.gif}}
!与えられた数値以下の最大の素数を探す
$ 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://www21051ue.sakura.ne.jp:8888/index.html]みたいな物を作ってみた。
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へ数枚の円盤を移動する
{{ref_image Tower_of_Hanoi_4.gif}}
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
[モンテカルロ法で円周率を求めるワンライナー|http://d.hatena.ne.jp/sugyan/20090315/1237086518] すぎゃんめもより
$ 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
[僕の車輪の再発明|http://kazuph.hateblo.jp/entry/20120310/1331396492]で教えて
もらったmojoliciousのwebsocketチャットを作ってみた。（写経しただけ。感謝!!)ubuntuのChrome、Fierfox、androidのChromeで動く事を確認しました。すごいねperl(mojolicious)。今度はチャボをwebsocket対応にしよう。[2014/4/14]
チャボとお話出きるようになりました。
[サンプル チャボ for WebSocket|http://www21051ue.sakura.ne.jp:3001/]
#!/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
%= javascript 'https://ajax.googleapis.com/ajax/libs/jquery/1.7/jquery.min.js'
<%= content %>