Perlの最近のブログ記事

pixiv さん が p.tl の APIを公開 してくれたので、

WWW::Shorten::ptl を作ってCPANに上げてみました。

どぞよろです。

Imager が 0.77 から Imager と Imager::File::PNG に分割されてて、mingw でのビルドがまためんどくさかったのでメモ。

手順１ まず Imager をいつもの方法(--incpath --libpath付き)でビルド. このとき、libpng***.dll が見つからないとか言われてもとりあえず無視して dmake test install

手順2 Imager::File::PNG を--incpath --libpath 付きで perl Makefile.PL する。 このとき libpng***.dll が見つからないって言われたら set PATH=.... でdllのあるところにPATHを通してから再度perl Makefile.PL する。

手順3 手順2で生成されたMakefileをエディタで編集。

1. LDDLFLAGS に --libpathで指定したディレクトリが書かれていなければ -L/path/to/lib を追加
2. EXTRALIBSとLDLOADLIBS を -lpng -lz に書き換える。
3. dmake test install
4. 手順2でDLLが無いって言われてた場合は該当DLLファイルを {perl}/site/lib/auto/Imager/File/PNG にコピー

注：何個か不要な操作が混じってる可能性あり

前回 の続き。

perl -E 'say scalar grep$_,map{$n=$_;map{substr($n,$_,1)eq 0}0..length()-1}0..1000'

ちゃんと「各桁の0を数えて」います。

.... ちゃんと？

ネタ元達 -> http://blogs.wankuma.com/episteme/archive/2010/07/22/191478.aspx
http://blogs.wankuma.com/andochin/archive/2010/07/22/191446.aspx
http://blogs.wankuma.com/esten/archive/2010/07/22/191451.aspx
http://hidori.spaces.live.com/Blog/cns!F11BB9FD8E1BC5F9!2495.entry
http://gist.github.com/415551 http://d.hatena.ne.jp/os0x/20081115/1226770265
http://d.hatena.ne.jp/mzp/20081115/countzero
http://d.hatena.ne.jp/rubikitch/20081112/1226490264
http://rubyist.g.hatena.ne.jp/krystal/20081110

んで、 perl で one-liner

perl -E 'say scalar grep!$_,map{split//}0..1000'

# ネタ元の紹介の方が長いとかどういう...

コード例は上がperl、下がvimコマンド

zero-width positive look-ahead: "abcdabcabcde" の中で 後ろに"cd"が付く"ab"だけを"ZZ"に変更したい。 ("ZZcdabcZZcde")

s/ab(?=cd)/ZZ/g;

:s/ab\(cd\)\@=/ZZ/g

zero-width negative look-ahead: "abcdabcabcde" の中で後ろに"cd"が付かない"ab"だけを"ZZ"に変更したい。("abcdZZcabcde")

s/ab(?!cd)/ZZ/g;

:s/ab\(cd\)\@!/ZZ/g

zero-width positive look-behind: "abc123ab123" の中で "abc"に続く "123" を "999" に変更したい。 ("abc999ab123")

s/(?<=abc)123/999/g;

:s/\(abc\)\@<=123/999/g;

zero-width negative look-behind: "std::"が付いてない"cout" を "std::cout" に変更したい。

s/(?<!std::)cout/std::cout/g;

:s/\(std::\)\@<!cout/std::cout/g;

最後のだけやけに具体的なのはそれがやりたくて調べてたからです。

後、別に不便してるわけじゃないけど、vimの正規表現ってnon-capture grouping ってできないのかなぁ..

-> 前回

自分がRTに投げたパッチとは違う形（かつもっとsimple)ではありますが、Net::Twitter-3.13004 にて、update APIを使用する際にNet::OAuthへ渡すパラメータのencodingがおかしかった問題は解決されました。(但し、3.13004 は 背景変更とアイコン変更が上手く動かないという問題があります( 3.13005で解決済み )

迅速に対応してくれた Marc Mims に感謝

一応 前回 の続き

lestrrat さんが RT でつついてくれたお陰もあってか、
昨日(?) Net::OAuth の修正版がリリースされ、
Net::OAuthが変なdecodeをすることはなくなりました。 (0.26以降)

自分のWindows Perl(mingw-gccでスクラッチビルド)環境でCPANモジュールを入れる際に普通にcpanm HogeHoge ではダメなやつのメモ

XML::Parser

• perl Makefile.PL EXPATINCPATH=/path/to/include EXPATLIBPATH=/path/to/lib

Imager

• Makefile.PL 中の libfiles=>$^O eq 'MSWin32' ? '-lpng -lzlib' : '-lpng -lz', の箇所、 -lzlib を -lz に変更
• perl Makefile.PL --incpath=/path/to/include --libpath=/path/to/lib

DateTime::TimeZone

• dmake の制約で PM_TO_BLIB設定箇所で「1行が長すぎる」みたいなエラーが出るので、PM_TO_BLIB= と PM_TO_BLIB += に適当に分ける

Tk

• Makefile.PL 中には -limm32 が指定されているのに Makefile には何故か -limm32 が入ってない。ので、Makefileのリンクオプション指定箇所に -limm32 を追加

WWW::Mechanize

• perl Makefile.PL --no-live --no-local

Web::Scraper

• optionalな XML::TreeBuilder::LibXML をインストールするかどうかの問いに n と答えるとテストが失敗するので force install する

WWW::Shorten::isgd

• テスト失敗するので force install

事の発端は、昨日 Net::Twitter をupgrade してpostしたらTwitterAPIから "Incorrect Signature" って返ってきてなんじゃらほい ってことから。

とりあえず、Incorrect Signature でぐぐって みたら perlのNet::Twitterを更新したらOAuthで日本語がpostできなくなった という記事を発見。ひとまずNet::Twitterを3.13001に落として様子見。

Net::Twitterの3.13001から3.13003へのdiffを眺めつつそこから呼び出されてるNet::OAuthを眺めつつ。

Net::Twitter で $Net::OAuth::SKIP_UTF8_DOUBLE_ENCODE_CHECK を設定してるけど 当のNet::OAuth側には該当変数のコメントに this is not actually used any more って書いてあるのを発見。（←2重エンコードのチェックは動いてないのかよ

Net::OAuthのコード(Net::OAuth::Message)をよくよく見ると

if ( Encode::is_utf8($str) ) {
  $str = Encode::decode_utf8($str, 1);
}

って書いてある。

・・・

ちょっと待て。既にUTF8フラグが立ってて文字列扱いなのに何でさらにデコードすんのん！？

ということで、if の条件を !Encode::is_utf8($str)に変更(↑のコードのすぐ下で URI::Escape::uri_escape_utf8($str)してるからdecode_utf8とencode_utf8の間違いではない)して、
且つNet::Twitter-3.13003 をインストールして 再度post

通った！（ノ・ヮ・ノ

拙い英語で rt.cpan.org にてNet::OAuthにチケット発行。 ← 今ここ

・・・

疲れた。

追記： タイトルのNet::OAuthのバージョンがえらい間違ってたので修正しました。 _o/L

ここ何ヶ月かの間、Perl界隈ではやれlocal::libだcpanminusだperlbrewだと、既存環境に手を入れずにローカルなモジュール環境を構築するという系の話が多くなってきてるような気がします。

local::lib はpixiv2rssをサクラ鯖上で動かす時に使ってみました。 perlbrew は環境をごっそり切り替える系なので、今のところ使うアテがない.

で、残りのcpanminusですが、この間からApp::cpanminusをインストールしてちょこちょこ使ってみてます。(cpanminusはApp::cpanminus以外に githubからstandalone版を持ってくるとか wget http://cpanmin.us/ | perl するとか色々あるみたい)

以下はその雑感です。

を、先ほどCPANにuploadしました。（ちょっと色々ミスってて最新版はいきなり0.02ですけど。

名前の通り、Module::Setupでバージョン管理に Bazaar を使う向きのプラグインです。

Module::Setupに元々入っている VC::Git を元にして作ったので、大体あってる筈。

デフォルトflavorを使ってる場合、MANIFEST.SKIPに ^\.bzr/の一行を追加してあげないとmake manifestでエラい事になるので要注意です。

ソースコードは この辺 に置いてあります。

現時点では search.cpan.org には反映されてないようです。一晩寝て起きたらきっと反映されてると思います。

問：以下のスクリプトの出力を想像してみましょう(perlのバージョンは5.8以降、スクリプトの文字コードはutf-8とする)

use utf8;
print 1 if "あ" =~ /\p{IsAlpha}/;
print 2 if "あ" =~ /\p{Alphabetic}/;
print 3 if "あ" =~ /[[:alpha:]]/;

.

..

...

モジュール一覧とか要らなければ、

# app.psgi
use Pod::Simple::XHTML;
use Pod::Simple::Search;

sub {
  my $env = shift;

  my $path = $env->{PATH_INFO};
  if ( $path eq '/' ) { return [ 200, [ ], ['It works!'] ]; }

  $path =~ s{^/}{};
  my $mod = $path;
  $mod =~ s{/}{::}g;

  my $filepath = Pod::Simple::Search->new->find($mod);
  if ( $filepath ) {
    my $podparser = Pod::Simple::XHTML->new;
    my $content = '';
    $podparser->output_string(\$content);

    $podparser->perldoc_url_prefix('/');
    $podparser->index(1);
    $podparser->parse_file($filepath);
    if ( $podparser->content_seen ) {
      return [ 200, [ ], [ $content ] ];
    }
  }
  [ 404, [ ], [ qq{not found $mod} ]];
}

で、 plackup すれば簡易podwebserverの出来上がり。

# @INC以下にあるモジュール一覧を収集してくれるモジュールってないのかなぁ..

とりあえず ネタ元 の問題にだけ反応

数値Xのフィボナッチ数を計算する。

perl -MMath::Fibonacci=term -E 'say term shift' {数値X}

指定された数値Xが素数であるかどうかを判定する。

perl -MMath::Prime::XS=is_prime -E 'say is_prime shift' {数値X}

ループを使わずに配列の順序を逆にする。

perldoc -f reverse

Fizz Buzz

perl -MAcme::FizzBuzz -e ''

以上。

ネタ元に曰く、 ライブラリ知識をあまり必要としない問題 らしいけど、
既に誰かが作ったのがあるんなら基本的には使った方が色々お得ですねよ。

ネタ元 に触発されて色々one-linerで書いてみた。 お題としては「100万回乱数生成を行いその平均値を計算する」です。

Perl (5.10.1)

perl -MList::Util=sum -E 'say((sum map rand,1..1e6)/1e6)'

List::Util++

Python (2.6.4)

python -c 'import random as r;print sum([r.random() for x in xrange(1000000)])/1e6'

xrange(1e6)だとwarningが出るので、仕方なく若干長めに。

Ruby (1.8.7)

ruby -e 'p 1000000.times.reduce{|r,i|r+rand()}/1e6'

sumはなかったけどreduceが組み込みのおかげでやたらと短い

PHP (5.2.12)

php -r 'function r1($i){return mt_rand()/mt_getrandmax();} echo array_sum(array_map("r1",range(1,1e5)))/1e5;'

見た目も残念な上に 1e6 だと 何故か動かなくて2重に残念な子でした。

Gauche (0.8.13)

gosh -usrfi-1 -E 'print (/. (fold + 0 (map (lambda(x) (/ (sys-random) RAND_MAX)) (iota 1e6))) 1e6)'

久し振りにScheme書いたよ。

元ネタ → 前回 と 同じとこ の 別記事

10分間コーディングというか、正確には寝る前に問題見て考えて、さっきコードに落として検証したんだけど。まぁコード考えるのに10分もかかってないよ多分。

元ネタ １ ２ ３

元ネタ１がpostされたのが 22:33

そのリンクを踏んで元ネタ２を開き、内容は読まずに(ぉ) 元ネタ３にたどり着き、

ざっと読んで(コード例は見てない) コード書いて、元ネタ３にあった例の検証が終わったのが 22:40 でした。

そんな感じで ↓が書いたコード

結論： favotterの穴埋め を作ってみた。

以下、背景とか

タイトルは適当

ネタ元→ 低レイヤの文字列操作 - おさかなラボ

ちょっとC書いてて、あるファイルがWindowsのスクリーンセーバーかどうか拡張子(.scr)で判別するロジックで、拡張子に大文字小文字がことがあることが判明したあと、ものすごくロジック書くのが面倒くさくなってきた俺はイラっときて次のように書いた。

   char *p = filename + strlen(filename);
    char lc = 'a' - 'A';
    if((*--p|lc) == 'r' && (*--p|lc) == 'c' && 
       (*--p|lc) == 's' &&  *--p     == '.'){
        // みつかったよ！
    }

まぁ、別にコードは間違ってはいないんだろうけど、

/* filename が ".scr" で終わってるかどうかチェックする */
char *p = filename + strlen(filename) - 4; /* 4 は ".scr" の文字列長 */
if ( p > filename && /* filename の文字列長が 4 より多いことのチェック */
    p[0] == '.' &&
    tolower(p[1]) == 's' &&
    tolower(p[2]) == 'c' &&
    tolower(p[3]) == 'r' )
{
  /* 見つかったよ！ */
}

とかの方が読みやすいんじゃないかな。拡張子名判定なんてそんなカリッカリにチューニングするようなもんでもないだろうし。

というわけで、クリスマスらしいＡＡのようなものを。

http://codepad.org/mdisVGHM

上からクリスマスキャンドル、雪の結晶、シャンパンとシャンパングラス、プレゼントを持ったサンタクロース 。 だ、そうです。

WWW::Pixiv という、CPANには登録されていないPerlモジュールがある。

一つは kuzuha さん作のもの。

• githubに置いてある
• ざっと見た感じ、機能は
  • タグを指定してイラスト情報をひっぱってくる
  • イラストIDを指定してイラスト情報をひっぱってくる
• の2つ。非常にシンプル。
• ドキュメントもちゃんとしてるっぽい。
• 今年の6月で開発が止まってる。もう枯れてる？

もう一つは私がこっそり作ってる。

• launchpadに置いてある
• まだまだ開発中
• タグ検索による一覧の他、新着一覧とかお気に入り新着一覧とかマイピク新着一覧とかランキングとか色々取ってこれる(はず)。
• 但し、現在 member_illust.php の関連部分をまだ作ってないのでイラストぶっこ抜きとかには使えない。
• 一応 pluggable なものを目指してる。もうちょい柔軟にplug-inできるようにしたい
• ドキュメントは Test::Pod::Coverage に文句言われない程度。(SYNOPSISはあるけど) 基本ソース嫁

共通点は、 Moose と Web::Scraper を使ってるってくらいかな

in EmotionMaker.pm

package EmotionMaker;
use base qw/Exporter/;
our @EXPORT = qw/happy cry smile/;

sub happy {":)"}
sub cry {":'("}
*smile = \&happy;

package me;
sub Make{print $_[1],"\n"}

in main.pl

use EmotionMaker;

Make me happy;
Make me cry;
Make me smile;
Make me confused;

$ perl main.pl
:)
:'(
:)
confused

smile を happy の alias にするとこ、2回ほど編集しまった。一発ネタなのにぐだぐだや

まずはこちらを。

use utf8;
use strict;
use warnings;
use Tk;
my $mw = MainWindow->new;

$mw->Label(-text => "\x{41}")->pack; # "A"
$mw->Label(-text => "\x{2600}")->pack; # BLACK SUN WITH RAYS
eval {
$mw->Label(-text => "\x{FE000}")->pack; # Google Emoji 晴れ 
};
warn $@ if $@;

use Encode;
use Encode::JP::Emoji;
use Encode::JP::Emoji::Fallback;
my $text = decode_utf8(
  encode('x-utf8-e4u-none', "\x{FE000}", FB_GOOGLE_TEXT())
);
$mw->Label(-text => $text)->pack;

MainLoop;

元ネタ → http://d.hatena.ne.jp/bleis-tift/20090930/1254309201
何か流行ってるみたいなので、やってみる。

perlは簡単すぎて面白くないので、

use List::Util qw/sum/;
print sum 1 .. (shift or 10);

明日9月10日から2日間にわたって開催される日本随一(唯一?)のPerlカンファレンス YAPC::Asia Tokyo 2009 に行ってまいります。

去年に引き続き開催地は東工大。なんか京都で開催とかいう噂もあったのですがどこへやら。 ていうか、京都でやってくれたら関西に住んでる身としてはありがたいのですがっ。

ほんとは今夜の前夜祭も行きたかったのだけど、まぁさすがに仕事あるしね。

そんなわけで、2日間楽しんで参ります

ネタ元→ 正規表現でn回目の出現にマッチってどうやるんだろう
にあまり深く考えずに
(?:pattern){N-1}(pattern) とか？
と返したわけだが、どう考えてもこれは「N個のパターンにマッチして、最後のパターンをキャプチャする」正規表現だ。ていうか
最後のパターンを後で参照したいだけならキャプチャ有り無しで分けずに(pattern){N} で十分だよ...

N個目のパターンにマッチする とはすなわちマッチ全体(Perlで言うと $&)がN個目のパターンになってなきゃいけないので、zero-width-look-behindを使って (?<=(?:pattern){N-1})pattern とするのが正解ですかね。

気をつけなければいけないのは、 Perlでの zero-width-look-behind はlook-behindするパターンにマッチする文字列の長さが確定していなければいけないこと。量指定子(*,+,? もしくは {n,m}) が含まれていてマッチする文字列の長さが確定できない場合は使えない。({n}は、固定の量指定子なので使える)

まとめると、

# 5個目のパターン(a5)を取り出したい
my $text = 'a1a2a3a4a5a6';
my $pat = qr/a\d/;
$\="\n";
print $1 if $text =~ m/(?:$pat){4}($pat)/; # $`='', $&='a1a2a3a4a5', $'='a6', $1='a5'
print $1 if $text =~ m/($pat){5}/; # ditto
print $& if $text =~ m/(?<=(?:$pat){4})$pat/; # $`='a1a2a3a4' $&='a5', $'='a6'
# ↓これは間違い
print $& if $text =~ m/(?<=$pat){4}$pat/; # $`='a1' $&='a2', $'='a3a4a5a6'
 
# 5個目のパターン(aa5)を取り出したい
$text = 'a1a2aa3a4aa5a6';
$pat = qr/aa?\d/;
print $1 if $text =~ m/($pat){5}/; # $`='', $&='a1a2aa3a4aa5', $'='a6', $1='aa5'
$text =~ m/(?<=(?:$pat){4})$pat/; # エラー

Net::Twitter は 相変わらずAPI引数のvalueだけをencode_utf8してくださるので、use utf8環境下で非ASCII文字をAPI引数のvalueに渡すと文字化けさせてくれます。文字化けの原因は以前に書いた通り

use utf8;
use Net::Twitter;

my $twitter = Net::Twitter->('略');
my $status = '日本語';
$twitter->update({status => $status}); # 文字化ける

no utf8 でkeyにUTF8フラグを付けないようにしておくと文字化けないです。

use utf8;
use Net::Twitter;

my $twitter = Net::Twitter->('略');
my $status = '日本語';
{ no utf8;
$twitter->update({status => $status}); # 文字化けない
}

もしくはkeyを全部encode_utf8してUTF8フラグを落としておくとか、しかしめんどくさい

Config::Pit 0.03 はWindowsでインストールしようとするとテストがこけるので、 t/01_basic.t の 57行目の後に、

SKIP: {
  skip "cannot test on Win32", 2 if $^O eq "MSWin32";
  # 残りのコード
}

とでもして、回避しませう。

Windowsでは shebang付けてchmod 0700 してもExecutableにはならんのじゃよ...

前回の をよりもだーんに。Net::Twitterのコードをちょっと参考にさせてもらいました。

コードは若干うるさいので more へ

CPANモジュールをアップデートしたらuse utf8してるスクリプトのNet::Twitter経由でのpostが文字化けるようになった。

な...　何を言ってるのか　わからねーと思うが （以下略

まぁ、結論から言うと、 戦犯は Net::Twitter だったわけですが。

package Test;
use Moose;

has message => (
  is => q/ro/,
  isa => q/Str/,
);

#----------------------------
package Test2;
use Moose::Role;

has plugged => (
  is => q/ro/,
  isa => q/Test/,
);

sub _plugin_ { 
  my $pkg = shift;
  my $subname = lcfirst $pkg;

  { no strict qw/refs/;
    if (!defined &{"Test::$subname"})
    {
      *{"Test::$subname"} = sub {
        my $self = shift;
        my $obj = $pkg->new(@_, plugged => $self);
        $obj->execute;
      };
    }
  }
}

requires q/execute/;

#----------------------------
package Test3;
use Moose;

with 'Test2';

has message => (
  is => q/ro/,
  isa => q/Str/,
);

sub execute
{
  my $self = shift;
  print join(", ", $self->plugged->message, $self->message), "!\n";
}

__PACKAGE__->_plugin_;

#----------------------------
package main;

Test->new(message => "Hello")->test3(message => "World");

こんなんでいいのかなぁ

ネタ元→ http://bbs.wankuma.com/index.cgi?mode=al2&namber=38363

ちょろっと.NETのクラスライブラリ眺めてみましたが、 .NETって標準ライブラリ使ってさくっとシャッフルすることって出来ないっぽい？

C++ なら std::random_shuffle, Perl なら List::Util でお手軽にシャッフルできるのにねー

#include <iostream>
#include <algorithm>
#include <iterator>
int main()
{
  int list[13];
  for (int i = 0; i < 13; ++i)
    list[i]=i+1;
  std::random_shuffle(list, list+13);
  std::copy(list, list+13, std::ostream_iterator<int>(std::cout, ","));
  return 0;
}

use strict;
use warnings;
use List::Util qw/shuffle/;
$,=',';
print shuffle 1 .. 13

CPAN に WWW::Twitpic::Fetch なるモジュールを登録しています。
ちょっと前に登録してちょこちょこ修正しつつ、先ほど v0.03 をリリースしました

追記(2009-07-11 02:00)： リリースしたと思ったらdistribution fileに余分なdirectoryが混ざってしまったらしくて、はじかれてしまいました orz
仕方ないのでバージョンだけ0.04に上げてリリース物を作り直して対処しました。

Twitpic からあれやこれやデータを拾うためのモジュールです。
直接画像ファイルをダウンロードするとかいう機能はわざと付けてませんが、
やろうと思えば割りと簡単にできてしまいます。
連続ダウンロードとかでサーバをいじめないようにしてくださいね。

今年も LLイベント の季節が近づいて参りました。 今年は LLTV ということでTelevisionがテーマのようです。

今週頭からチケットは販売されていて まだ売り切れてはいないと思うので、Perl, Ruby, Python その他軽量言語に興味をお持ちの方は是非にお足をお運びいただければと思います。毎回面白いよ！

HASHのサイズを効率よく取る方法を考えてみた。

scalar %HASH が 要素数/バケツ容量を返すのでごにょごにょしようかと考えてみた

ふと perldoc -q hash してみた。

答えが書いてあった ＼（＾ｏ＾）／

ネタ元 → 東方算程譚 - 以下について教えてあげよう♪

perl でやってみた

use strict;
use warnings;

my $s='Abc012_59F_#012Gh';
substr($s, 0, do{my $i = index($s,'#')+1; $i?($i):()}) =~ tr/A-Za-z0-9/a-zA-Z9876543210/;
print $s;

substr で文字列先頭から"#"までを取り出して tr///で文字変換します。

perlの substr が返す値は左辺値として使えるのです。なんとなんと

perldoc -f map

map には map BLOCK LISTとmap EXPR, LIST の2通りあるが、
第1引数が { で始まる場合、どちらの形式(BLOCK or EXPR (HASHREF) )として解釈するかは、
閉じ}の後ろを見て決定するのではなく、{ の後ろに何が来るかで決まる。らしい

map { $_ } @list; # BLOCK
map { "$_" } @list; # BLOCK
map { $_ => 1 } @list; # BLOCK
map { "$_" => 1 } @list; # EXPR(!) この行はSyntax Error
map { +"$_" => 1 } @list; # BLOCK  
map { func($_) => 1 } @list; # BLOCK
# おまけ
map func, @list; # EXPR
map "<$_>", @list; # EXPR
map "<$_>" => 1, 2 .. 3; # EXPR("<$_>")  1, 2 .. 3 が LIST (結果は ("<1>", "<2>", "<3>") )
map ("<$_>" => 1), 2 .. 3; # EXPR("<$_>") 1 が LIST、 2 .. 3 はmapの適応範囲外 (結果は ("<1>", 2, 3) )
map (("<$_>" => 1), 2 .. 3); # EXPR( ("<$_>"=>1) ) 2 .. 3 が LIST (結果は ("<2>", 1, "<3>", 1) )

unixのwhich(1) のようなものを作ってみるテスト

元ネタ： http://twitter.com/melponn/statuses/1565586704 とか http://twitter.com/melponn/statuses/1565590431

カッとなって作ってみた。(RSSフィードを取ってきてはてダの下書きに追記していくだけです 自動と言ってしまっていいのか微妙なところですが、まぁいいや

は、いいけど私はHatenaのアカウントを持ってないのでテストすらできないのでありました。(チャンチャン

でもまぁ、一応コードは晒しておきます。

twitter2hatena.pl

使ってみてバグがあったら教えてくださいｗ

ちょっと間が空きすぎですが、
過日行われた JPAセミナー#02 に参加してきました。

今更ながら、
firefox 3が遅くなった→ SQLite reindexで解決＆高速化
ということを知ったので、
.sqliteファイルをreindexしてまわるスクリプトを書いた。

use strict;
use warnings;

use DBI;
use File::Find;

if ( !@ARGV ) {
  print "$0 <base dir>";
  exit;
}

my $basedir = shift;
die "$basedir not found" if !-d $basedir;

find(\&reindex_dbfile, $basedir);

sub reindex_dbfile
{
  my $dbfile = $File::Find::name;
  return if $dbfile !~ m{\.sqlite$};

  print "reindexing $dbfile...\n";

  my $dbi = DBI->connect("dbi:SQLite:dbname=$dbfile", "", "");
  if (!$dbi) {
    print STDERR "cannot open $dbfile\n";
    next;
  }
  reindex($dbi, $_) for get_tables($dbi);

  print "done\n";
}


sub get_tables
{
  my $stm = shift->prepare(<<EOS);
SELECT name FROM sqlite_master WHERE type IN ('table', 'index') UNION ALL
SELECT name FROM sqlite_temp_master WHERE type IN ('table', 'index')
EOS

  $stm->execute;
  map { $_->[0] } @{$stm->fetchall_arrayref};
}

sub reindex
{
  my($dbi, $table) = @_;
  print "-> $table\n";

  $dbi->do("REINDEX $table");
}

.. 確かに起動が早くなった気がする！

ちなみにSQLiteでtable一覧を取得する方法は ここ 経由 この辺 を参照しました。多謝多謝。

2009-05-12 15:50 追記： tableだけじゃなくてindexもreindexするように変えてみました。意味があるかどうかは知らない(ぉ

Encode::Detect 1.01 のインストールも一筋縄でいかんかったのでメモ。

普通にビルドしようとすると Detector.dll のビルド時に undefined reference to 'boot_Encode__Detect' って言われるのですよ。

• Encode::Detect のtarballを展開
• Detector.pm を書き換え
  • Encode::Detect::Detector->bootstrap($VERSION); となっている箇所を bootstrap Encode::Detect::Detector; に書き換える。($VERSION引数削るだけでいいのかな？どうなんだろ..
• Build.PL を書き換え
  • module_name を "Encode::Detect::Detector" にして pm_files から Detect.pm の定義をコメントアウト
• perl Build.PL && dmake test install
• Build.PLを再度書き換え
  • module_name を "Encode::Detect" に戻し、pm_files から Detect.pm の定義を戻して Detector.pm の定義をコメントアウト。また c_sources や xs_files なども削っておく。
• 再度 perl Build.PL && dmake test install
• めでたしめでたし で あってくれ

libdbの準備

• Oracle Berkeley DB Downloads からtarballを持ってくる
• msys上 で tar xvzf db-***.tar.gz
• cd build_unix/ して ../dist/configure
  • configure のオプションは
    • --prefix=/usr/local (お好みで
    • --disable-shared (これもお好みで
    • --enable-mingw (超重要 これ付けないとMinGWでビルドできない。
• 後は普通に make install

DB_Fileのインストール

• Windowsプロンプトに戻って
• DB_Fileのtarballを一旦展開
• config.in を編集して、INCLUDE と LIB を書き換える
  • (環境変数 DB_FILE_INCLUDE と DB_FILE_LIB を設定するのでもいいのかな。まぁお好みで
• perl Makefile.PL と dmake test install
• めでたしめでたし

前回 の続き。四則演算のパースに挑戦。

括弧が使えるようになるのと、単項+- に気をつけて、EBNFは

expr = NUM
     | expr '+' expr
     | expr '-' expr
     | expr '*' expr
     | expr '/' expr
     | '(' expr ')'
     | '-' expr
     | '+' expr

以下、注意点

結合順序の問題： 例えば 1+2*3-5 を計算順序の曖昧さをなくして (1+(2*3))-5 と認識させるために 2項演算子に優先度をつけなければいけません。当然'*','/'の方が優先度高です。

「数」の表現： 正負を示す単項演算子を設定したので、 NUM は頭に'+'も'-'もつかない数値 でなければなりません。

'+', '-'の曖昧さ： 単項演算子'+','-' と2項演算子'+','-'との曖昧さをなくすため、単項演算子の優先度を2項演算子のそれより高くします。とはいえ、同じトークンで優先度設定することはできないので、'+' expr, '-' exprのルールに特殊な指示を入れます。

そんなこんなでできたコードが

最近、仕事でDSLの機能拡張をする機会があったのですが、構文解析とかその辺の話はあんましよく知らない(EBNFは適当に書けるし、 boost::spirit も触ったことはあるけど、本格的なのは初めて。ちなみに仕事のはRubyの Racc が使われてる)ので、手習いにPerlで使えるパーサジェネレータで逆ポーランド記法の電卓を書いてみようと思い立った。

EBNF は超有名な

expr: expr expr '+'
    | expr expr '-'
    | expr expr '*'
    | expr expr '/'
    | NUM

です。

とりあえず、Perlのパーサジェネレータで有名だと思っているのは Parse::RecDescent なので、早速

...

...

動いてくれないので色々調べてみたら P::RD が使ってる再帰下降法は 逆ポーランド記法の様な 最左再帰 の構文を処理できないということでした。ｼｮﾝﾎﾞﾘ

気を取り直して LR法を使っているパーサジェネレータということで、 Parse::Eyapp を試してみた

前回 の追試。

List::Compareに食わす前に sort+uniq したものと、 IO::* でprintするときにjoin("\n", LIST) で一気に食わしたものとを追加しておうちマシン(Core2Duo 3GHz, 3GBメモリ)で再計測してみました。(後、後ろ切れるので普通のparagraphで..)

Benchmark: timing 10000 iterations of IO::Scalar(join)+Search::Dict, IO::Scalar+Search::Dict, IO::String(join)+Search::Dict, IO::String+Search::Dict, List::Compare, List::Compare(sorted), hash, hash+exists...
IO::Scalar(join)+Search::Dict: 32 wallclock secs (31.75 usr + 0.00 sys = 31.75 CPU) @ 314.96/s (n=10000)
IO::Scalar+Search::Dict: 39 wallclock secs (38.56 usr + 0.00 sys = 38.56 CPU) @ 259.32/s (n=10000)
IO::String(join)+Search::Dict: 32 wallclock secs (31.83 usr + 0.00 sys = 31.83 CPU) @ 314.19/s (n=10000)
IO::String+Search::Dict: 51 wallclock secs (50.67 usr + 0.00 sys = 50.67 CPU) @ 197.35/s (n=10000)
List::Compare: 83 wallclock secs (82.03 usr + 0.05 sys = 82.08 CPU) @ 121.84/s (n=10000)
List::Compare(sorted): 110 wallclock secs (109.73 usr + 0.14 sys = 109.87 CPU) @ 91.01/s (n=10000)
hash: 22 wallclock secs (21.30 usr + 0.05 sys = 21.34 CPU) @ 468.52/s (n=10000)
hash+exists: 21 wallclock secs (21.00 usr + 0.02 sys = 21.02 CPU) @ 475.83/s (n=10000)

IO::*にjoinしてから食わすのは、ずいぶんと早くなりますね。その代わりメモリ食うんでしょうけど。

逆に、事前にsort+uniqしたList::Compare版はえらく遅くなってしまってます。余計なことすんなってか..

元ネタ の方にコメントもしてますが..
Perlで2配列の積集合(Intersection)を取る方法を何個か考えたので、Benchmark取ってみた。

use strict;
use warnings;
use Benchmark;
use List::Compare;
use IO::String;
use IO::Scalar;
use Search::Dict;
use List::MoreUtils qw/uniq/;

my @l1 = map { int rand 1000 } 1..1000;
my @l2 = map { int rand 1000 } 1..1000;

timethese(10000, {
    q/List::Compare/ => sub {
      List::Compare->new(\@l1,\@l2)->get_intersection;
    },
    q/hash/ => sub {
      my %in_l1 = map { $_ => 1 } @l1; 
      grep { $in_l1{$_} } @l2;
    },
    q/hash+exists/ => sub {
      my %in_l1 = map { $_ => undef } @l1;
      grep { exists $in_l1{$_} } @l2;
    },
    q/IO::String+Search::Dict/ => sub {
      my $ios = IO::String->new;
      $ios->print($_,"\n") for (uniq sort {$a cmp $b} @l1);
      grep { -1 != look $ios, $_ } @l2;
    },
    q/IO::Scalar+Search::Dict/ => sub {
      my $ios = IO::Scalar->new(\my $data);
      $ios->print($_,"\n") for (uniq sort {$a cmp $b} @l1);
      grep { -1 != look $ios, $_ } @l2;
    },
  }
);

Search::Dictは二分木検索の実装です。が、辞書ファイルからの検索を目的としてるモジュールのようなので、一旦辞書を作る必要があります。

手元のマシン(PenD 3.20GHz, メモリ3.5GB)での実行結果は、

Benchmark: timing 10000 iterations of IO::Scalar+Search::Dict, IO::String+Search::Dict, List::Compare, hash, hash+exists...
IO::Scalar+Search::Dict:  83 wallclock secs ( 81.27 usr + 0.03 sys =  81.30 CPU) @ 123.01/s (n=10000)
IO::String+Search::Dict: 110 wallclock secs (108.52 usr + 0.02 sys = 108.53 CPU) @  92.14/s (n=10000)
          List::Compare: 167 wallclock secs (166.36 usr + 0.23 sys = 166.59 CPU) @  60.03/s (n=10000)
                   hash:  35 wallclock secs ( 34.64 usr + 0.05 sys =  34.69 CPU) @ 288.28/s (n=10000)
            hash+exists:  34 wallclock secs ( 33.75 usr + 0.08 sys =  33.83 CPU) @ 295.61/s (n=10000)

やっぱり hash 強いなー。 そして分かりやすさではダントツの List::Compare はスピード面では散々な結果に..

ツンデレ実装 の改造をしていて妙な壁にぶち当たってしまった。

# やばっ 普通に答えたらイカんのかな、これ(ビクビク

επιστημηさんの 祭りの仕掛け に 引っかかってみました。

use strict;
use warnings;
use encoding q/utf-8/, Filter => 1, STDOUT => q/cp932/;
use utf8;
use Scalar::Util;

package ツンデレ;

sub new {
	my $pkg = shift;
	my %arg = @_;
	die "失格" if !exists $arg{デレに変わる条件};
	bless \%arg, $pkg;
}

sub 態度 { shift->きっかけ || print "ツン" }

sub きっかけ {
	my $self = $_[0];
	if ( $self->{デレに変わる条件}->($self) )
	{
		no strict qw/refs/;
		my $pkg = 'ツンデレ::_' . Scalar::Util::refaddr($self);
		eval "package $pkg; our \@ISA = (q/ツンデレ/);";
		die $@ if $@;
		*{$pkg . '::態度'} = sub { print "デレ" };
		$self = bless $self, $pkg;
		$self->態度;
		$self;
	}
}

sub 相手 {
	my $self = shift;
	$self->{相手} = shift;
	print "\n相手は " . $self->{相手} . "\t";
	$self;
}
package main;
srand(time);

sub 突発的事項 { int rand 20 }
sub 発生した { 0 };

my $あの子 = ツンデレ->new(
	デレに変わる条件 => sub {
		my $self = shift;
		$self->{$self->{相手}}{訪問回数}++ > 5;
	});

$あの子->相手(("scott", "andrei", "epi")[int rand 3])->態度 for 1 .. 20;
print "\n";

my $その子 = ツンデレ->new(
	デレに変わる条件 => sub {
		突発的事項 == 発生した
	});
$その子->態度 for 1 .. 20;
print "\n";

my $ビッチ = ツンデレ->new(
	デレに変わる条件 => sub { 1 });
$ビッチ->態度 for 1 .. 5;
print "\n";

eval {
	my $普通の子 = ツンデレ->new(); # エラー
};
print $@ if $@;

最初は「ツンツン」した態度だけどある条件をクリアすると「デレ」に移行するというタイプのツンデレの実装になります。なお、デレに変わる条件がない場合はツンデレとは認められません。

ツンデレ移行判定はStrategyパターンで。ツンからデレに移行するのは、インスタンス毎にツンデレのサブクラスを動的に生成して、インスタンスをそのサブクラスに所属替え(rebless)して"態度"を変える という多少強引な事をやってます。

use encoding の STDOUT => q/cp932/ は、Windows上で動かしてるからなだけです。

http://floralcompany.jp/archives/2009/02/obsolete.html のおまけ。

perlならone-linerでいけるよね っと。

perl -e 'print join q/ /, grep { grep /^Tag:.*special::obsolete/, qx/apt-cache show $_/ } map { (split /\s+/)[1] } grep /^.i/, split qq/\n/, qx/dpkg -l/'

DateTime::TimeZone をupdate中に気付いたんだけど、 Win32::TieRegistry (v0.25) の SubKeyNames が失敗することがある。

ざっと見てみたところによると、 Win32::TieRegistry::_NoMoreItems() が正しく真値を返さないせいで、Win32::TieRegistry::_enumSubKeys() で subkeys が設定されていない様子。(なので、subclassesもsubtimesも設定されない)

Win32::TieRegistry::_NoMoreItems() は、Win32::WinError が入っていない状態だと、 Win32::FormatMessage(Win32::GetLastError()) =~ m/^No more data/ を返す。
なので、Win32::FormatMessage() がlocaleに合わせたメッセージを返してくると、マッチが成功せず、真値を返すべきところ間違って偽値を返してしまう。

修正については現在 RT で議論されているので、とりあえずのworkaroundを..

# Win32::TieRegistry
sub _NoMoreItems
{
    return 1 if _ErrNum== 259; # <-- これを追加。(259は No more items のエラーコード)
    return
      $_NoMoreItems =~ /^\d/
        ?  _ErrNum == $_NoMoreItems
        :  _ErrMsg =~ /$_NoMoreItems/io;
}

... Win32::WinError 入れろって？ ごもっとも..

ハノイの塔 をたくさんの言語で。

唐突に書きたくなって、頑張って色々書いてみた。（残念ながらスタック型言語(Brainf*ckとかwhitespaceとかは無い)

ハノイの塔回答プログラムのポイントはおおよそ2点

• 関数/サブルーチン等の再帰呼び出し処理
• 経過を出力する際の文字列フォーマッティング

それでは、どうぞ

たまには季節ものの話題でも。

$ perl -E 'say trick or treat'

$

...

何ももらえなかった（´・ω・｀

気を取り直して..

$ perl -E 'say "trick" or "treat"'
trick
$

...

いたづらされますた

このままではお菓子はもらえない。一大事。どうしよう.

元ネタ→ http://twitter.com/nakawankuma/status/973288693 及びその周辺

こうですか＞＜

use strict;
use warnings;

use IO::File;
use File::Find;
use threads;
use Thread::Queue;

my $max_threads = 7;

if (@ARGV < 3) {
  print "usage: $0 <pattern> <file-pattern> <basedir> [<basedir> ...]\n";
  exit;
}
my $pattern = shift;
$pattern = qr/$pattern/;

my $fpattern = shift;
$fpattern = $fpattern ? qr/$fpattern/ : undef;

my $q = Thread::Queue->new;
my @thr = map { threads->create(\&grep_each, $q) } 1 .. $max_threads;

find({ wanted => sub {
    $q->enqueue($_) if -f $_ && (!$fpattern || $_ =~ m{$fpattern});
  }, no_chdir => 1}, @ARGV);

$q->enqueue(undef) for @thr;
$_->join for @thr;

sub grep_each
{
  my ($q) = @_;

  while ( my $file = $q->dequeue ) {
    my $f = IO::File->new($file);
    if ( !$f ) {
      print STDERR "*** cannot open $file\n";
      next;
    }
    
    my $i = 1;
    for my $line ( <$f> ) {
      print "$file:$i:$line" if $line =~ m{$pattern};
    }
    continue {
      ++$i;
    }
  }
}

pattern file-pattern 共に正規表現を指定(globパターンじゃないよ)なので、そこだけ注意だ！

Req:タイマー張りたい

my $id = $widget->after($milliseconds, \&callback); # 一回きり
my $id2 = $widget->repeat($milliseconds, \&callback2); # 繰り返す

Req: タイマーキャンセルしたい

$id->cancel; # または
$widget->afterCancel($id);

Req: Tk::Entry 内でEnterキーを押されたらhogehogeしたい

$entry->bind('<Return>' => sub { hogehoge; });

Req: MainWindowのLoad後にhogehogeしたい (VBでいうとこのFormLoadイベントハンドラ)

$mainwnd->bind('<Expose>' => sub { hogehoge; });

• libjpeg
• libpng
  • libz
• libgif (giflib)

cpan/cpanp から一旦install、builddir に行って、 --incpath --libpath 付きで再構築

で、いいのかな。--incpath --libpath がcpan/cpanp から指定できればいいのだけど..

タイトル横にカテゴリを入れて、シグニチャ付けて。

タイトル [カテゴリ] (URL) [at FloralCompany.log]

って感じのフォーマットになってるはず

fork と thread の話 の続き。

とりあえず、Expect に関しては、 threadが走ってないときにExpectを利用することは可能でした。即ち、

use threads;
use Expect;

my $thr = threads->create(\&parallel);
my $exp = Expect->spawn(...);
# 何とかかんとか
$thr->join;

sub parallel { sleep 5; }

はダメだけど、

use threads;
use Expect;

threads->create(\&parallel)->join;
my $exp = Expect->spawn(...);
# 何とかかんとか
threads->create(\&parallel)->join;

sub parallel { sleep 5; }

は問題なく動く。もちろん複数thread でもokで、ちゃんと全子threadがjoinされた状態であればforkはまともに動くらしい。

ちなみに ActivePerl のfork はthreadで実装されているらしいので、元々大丈夫だったかもしれない。(しかしExpectは入らない..

twitter で三項演算子の話が出てたんで、なんとなく5.10以前のperl流switch-case の3項演算子版を書いてみる、

use encoding q/utf8/, Filter => 1;
$_ = 君がいた季節();
my $season = /Spring/i          ? 0 :
             /Summer/i          ? 1 :
             /(?:Autumn|Fall)/i ? 2 :
             /Winter/i          ? 3 : die "unkown season";

大体こんな感じ。 "?" を縦に並べると視認性もup

fork と thread も混ぜちゃだめらしい。

threadで並行して Expectでリモートコマンド発行とかやってみたんだけど、Expectが内部でforkを使うらしく、うまく動作しませんでした。

threadで並行させたかったら、通信モジュール(Net::TelnetとかNet::SSHとか)を直に弄れってことですね。

use threads と use encoding を混ぜるとダメらしい。

use threads;
use encoding q/utf8/、STDOUT => q/utf8/;
sub test{print"日本語";}
threads->create(\&test)->join;

とかがセグメンテーション違反で落ちます。

encoding のPODには threadと一緒に使うな、って書いてありますね。

use encoding じゃなくて use Encode して encode/decode する分には問題ないので、それで回避しましょう。

複数行ある文字列を Test::More::is で比較すると、失敗したときにどこが違ってるのか判りづらいので、 Test::More::is_deeply を使って

is_deeply [split /\n/,$got], [split /\n/,$expected]

とかやるとイイみたいですわよ

CSVファイルに日本語が入ってる場合は、

use DBI;
use Text::CSV_XS;
my $dbh = DBI->connect(q/DBI:CSV:/, q//, q//);
$dbh->{csv_csv} = Text::CSV_XS->new({binary=>1});

但し、取り出した後で Encode::decode とか忘れないように！

改行が \r\n じゃない場合は Text::CSV_XS のコンストラクタパラメタに eol=>qq/\n/ とか渡しちゃえ。

-> 参考元

メモ：ParserDetails.ini が見つからないって言われたときの対処法。

http://perl-xml.sourceforge.net/faq/#parserdetails.ini

要約：XML::SAX経由でparserを登録してやればok.

トップページが寂しくなってきたのでとりあえず投下

さて、どうやりましょ。ビギナなら

void func(int cond)
{
  int n;
  if ( cond )
    n = 0;
  else
    n = 1;
}

なんてのもありですかね。しかしこの程度なら3項演算子を使って

void func(int cond)
{
  int n = cond ? 0 : 1;
}

の方がスマートですね。しかし条件が複雑になってくると3項演算子では読みにくくなるので、前者の方がよいかもです。

下記のようなコードを書いたらperlにmain::aは一回しか使われてないよ。typoじゃね？みたいな警告を食らった。

use strict;
use warnings;

use List::MoreUtils qw/pairwise/;

my (@hoges, @hugas);

my %pairs = pairwise {
  my ($hoge, $huga) = ($a, $b);
  # 何とかかんとか
} @hoges, @hugas;

アクセス解析を眺めてると、コンスタントに「wav cue 分割」とかで引っかかってくる人がいる。引っかかってる記事は これ なんだけど、中々これを以って目的が達せられるとは思いがたく。

この際、手が空いたら Wav分割機能をモジュール化しようかな、と思ったり。 Audio::Wav::Splitterあたりに、分割する機能を持たせて、 Audio::Wav::Splitter::Cuefileがcueファイルから分割情報を持ってくる感じ？

問題はテストがちょっと難しそうだってとこだけど... うーむ

下記のコードを regexp.pl とでも名前を付けて保存して、perl -MO=Deparse regexp.pl を実行してみよう。そこには何が表示されたか。

m/hoge/;
m,hoge,;
m!hoge!;
m"hoge";
m#hoge#;
m$hoge$;
m%hoge%;
m&hoge&;
m(hoge);
m-hoge-;
m=hoge=;
m^hoge^;
m~hoge~;
m|hoge|;
m\hoge\;
m@hoge@;
m[hoge];
m{hoge};
m`hoge`;
m:hoge:;
m*hoge*;
m;hoge;;
m+hoge+;
m/hoge/;
m.hoge.;
m<hoge>;
m'hoge';
m?hoge?;

perl(v5.7.3以降) の標準モジュールに Memoize というのがある。何をするやつかというと、perldoc 曰く

Make functions faster by trading space for time

「（計算）時間と（メモリ等の）領域とを取引して、関数を早くします」ということで、メモ化を行ってくれるモジュールです。

またしてもソートネタ。

ネタ元はどうかく？org のお題で、データ同士の比較を行わないまじめなコードはそっちに投稿したので、ふと思いついた邪悪コードの方を載せてみます。

社内の掲示板で 「『3 4 7 8』と『+ - * / ()』を使って10を作るには？」
という他愛もない問題が出され、なぜか約3名によるコードの貼り付け合戦になってしまいました。
(いや、私がPerl x 2, Scheme x 1 を貼っただけで、他の2名はそれぞれRuby, VBScript x 1でしたが。)

いやはや、新人教育に関する話題のはずだったのに、迷惑な話だｗ

Ruby公式ドキュメントの trap::スコープ、制御構造 より、

・ローカル変数は本当にローカル。Perl の my とかとは違う

# Ruby
local = "hoge"
def hoge
  print local, "\n" # 未定義。エラー
end
hoge

# Perl
my $local = "hoge";
sub hoge {
    print $local, "\n"; #=> hoge
}
hoge;

NekoMimiFu** を見て、
NekoMimiFu**インタプリタのPerl版を作ってみました。
ネタ的には今更感バリバリですけど。

# 2008-07-08 追記。コードが長いので続きに移しました。

dankogaiさんの nested list comprehension のperl版に対抗(?)して、
eval() を使わない版を書いてみました。

# 2008-07-08 追記 コードが長いので続きに移動しました。

Perl5.10になって、switch文 が正式に使えるようになりました。

# code 1
use feature q/:5.10/;
my $i = 5;
given ($i) {
  when (4) { say "Oops" }
  when (5) { say "yes" }
  when (6) { say "Oh No" }
  default { say "no" }
}

smart matching と相まって非常に便利です。

が、旧来のswitch技法との組み合わせ技である

# code 2
my $i = 5;
my $r = do {
  if ( $i== 4 ) { "Oops" }
  elsif ( $i== 5 ) { "yes" }
  elsif ( $i== 6 ) { "Oh no" }
  else { "no" }
};

や

# code 3
my $i = 5;
my $r = ( $i== 4 ) ? "Oops" :
        ( $i== 5 ) ? "yes"  :
        ( $i== 6 ) ? "Oh no":
                      "no";

相当のものはどうもgiven-when単体ではできなさそう。

# code 4
use feature q/:5.10/;
my $i = 5;
my $r = do {
given ($i) {
  when (4) { "Oops" }
  when (5) { "yes" }
  when (6) { "Oh No" }
  default { "no" }
}};

とやっても code 4 の $r には undef が入ってるご様子。

もちろん、

# code 5
use feature q/:5.10/;
my $i = 5;
my $r = eval {
given ($i) {
  when (4) { return "Oops" }
  when (5) { return "yes" }
  when (6) { return "Oh No" }
  default { return "no" }
}};

はうまく行くけど、何か違う気がするし..

何だろう。switch statement は EXPR じゃないってのは判るけど、
do BLOCKのreturn valueであるvalue of the last command in the sequence of commands indicated by BLOCK.(perldoc -f do)は一体どれだ？？

#!perl
#

use strict;

sub f;
sub g;
sub h;

use Time::HiRes;

my $t = Time::HiRes::time;
print h(100), "\n";
printf "%-10.2f ms elapsed\n", (Time::HiRes::time - $t)*1000;

sub f {
  my $n = shift;
  if ( $n == 1 ) {
    1;
  }
  elsif ( $n % 2 ) {
    3 * $n + 1;
  }
  else {
    $n / 2;
  }
}

sub g {
  my $n = shift;
  my $cnt;
  do {
    ++$cnt;
  } until ( ($n = f($n)) == 1 );
  ++$cnt;
}

sub h {
  my $n = shift;

  my $k;
  my $max_g;
  for ( 1 .. $n ) {
    my $g = g($_);
    if ( $g > $max_g ) {
      $k = $_;
      $max_g = $g;
    }
  }
  $k;
}

#!perl
#

use strict;

use Language::Functional qw(:all);
use Time::HiRes;

my $t = Time::HiRes::time;
print h(100), "\n";
printf "%-10.2f ms elapsed\n", (Time::HiRes::time - $t)*1000;

sub f {
  my $n = shift;
  if ( $n == 1 ) {
    1;
  }
  elsif ( $n % 2 ) {
    $n*3+1;
  }
  else {
    $n/2;
  }
}

sub g {
  my $n = shift;
  my $c;
  Until { ++$c && shift() == 1; } \&f, $n;
  $c;
}

sub h {
  my $n = shift;
  my $max = maximum([map {g($_)} (1..$n)]);
  
  head(filter sub {g(shift) ==  $max}, [1..$n]);
}

sub f{
  my $n = shift;
  ($n % 2) ? $n*3+1 : $n/2;
}

#!perl
#

use strict;

sub g;
sub h;

use Time::HiRes;

my $t = Time::HiRes::time;
print h(100000), "\n";
printf "%-10.2f ms elapsed\n", (Time::HiRes::time - $t)*1000;

sub g {
  my $n = shift;
  $n == 1 ? 1 : 1 + g(($n%2) ? $n*3+1 : $n/2)
}

sub h {
  scalar((
    sort { $b->[1] <=> $a->[1] } 
    map { [$_, g($_)] } 1 .. shift
  )[0])->[0];
}

LL2006の、「君ならどう書く」の読者参加版ができていた。
お題は

「100までの整数から素数を列挙せよ」です．

perl -MMath::Prime::XS -e 'print join(q/ /,Math::Prime::XS::primes(100))'
perl -MMath::Prime::Simple -e "print join(q/ /,@{Math::Prime::Simple::primes([0,100])->[0]})"

うん、多分完璧。

• Audio::Wave
• Audio::Cuefile::Parser

#!/path/to/perl
#

use Audio::Cuefile::Parser;
use Audio::Wav;
use File::Basename;
use File::Spec;

sub index2second($);

my $cue = Audio::Cuefile::Parser->new(cue_filename.cue);

my $path = $cue->file;
my $name = $cue->title or basename($path, qw(.wav));

my $wav = Audio::Wav->new;
my $r_wav = $wav->read($path);

my $samples_per_seconds = $r_wav->length_samples / $r_wav->length_seconds;
print "Samples/Second (Bit-Rate): ", $samples_per_seconds, "\n";

my @data;
foreach ( $cue->tracks ) {
	my ($idx, $pos) = ($_->index, $_->position);
	my $filename = $name . '_' . $pos;
	$filename .= '_' . $_->title if ($_->title);
	$filename .= '.wav';

	print sprintf("Position: %s, Index: %s\n", $pos, $idx);
	my ($sec, $frm) = index2second($idx);
	my $smp = int(($sec + ($frm / 75.0)) * $samples_per_seconds);
	print sprintf("from %U secs, %U frames (%U samples)\n", $sec, $frm, $smp);

	push @data, [ $filename, $smp ];
}
push @data, [ undef, $r_wav->length_samples ];

foreach ( 0 .. $#data - 1) {
	my ($file, $s_idx, $s_idx_next) = 
		($data[$_][0], $data[$_][1], $data[$_+1][1]);
	my $smp_length = $s_idx_next - $s_idx;
	
	if ( $file ) {
		$r_wav->move_to_sample( $s_idx );
		my $w_wav = $wav->write( $file, $r_wav->details() );
		my $written_smp =
			$w_wav->write_raw_samples(
				$r_wav->read_raw_samples( $smp_length ) );

		print sprintf("File: %s, %U samples written\n", $file, $written_smp );
		$w_wav->finish;
	}
}
sub index2second($)
{
	$_ = shift;
	/(\d+):(\d+):(\d+)/ || die "$_ is not time index";
	(($1 * 60) + $2,  $3);
}

HTML::Template

HTML側：

<TMPL_VAR NAME=HOGE>

Perl側：

use HTML::Template;
my $tmpl = new Template(filename => 'hoge.html');
# my $tmpl = new Template(scalarref => $ref_to_text);
# my $tmpl = new Template(arrayref => $ref_to_array);
$tmpl->param(HOGE => $HOGE);
print $tmpl->output;


Text::SimpleTemplate

HTML側:

<% $HOGE %>

Perl側:

use Text::SimpleTemplate;
my $tmpl = new SimpleTemplate;
$tmpl->setq( HOGE => "hoge" );
$tmpl->load("hoge.tmpl");
print $tmpl->fill();
# $tmpl->fill(OHANDLE = \*STDOUT);