Perlの最近のブログ記事

2013-09-19~21に慶応大学日吉キャンパス協生館にて行われたYAPC::Asia Tokyo 2013に参加してきました。

以下、各日の感想など

カッとなって書いた。反省はしてない。

参考: ボゴソート - Wikipedia

ちなみに、コメントアウトしてある方のboardが解答できたところは見てません。

去る2013-02-23に、大阪富国生命ビル内 ヤフー株式会社さま会議室(?)で行われました、 Kansai.pm 第15回ミーティングに参加しました & LT喋ってきました。

以下、適当に感想など

2012-09-27(Thu)〜29(Sat) に東京大学本郷キャンパス内で行われた 世界最大のPerlのお祭り、 YAPC::Asia Tokyo 2012 に参加&ちょろっとLT登壇させていただきました。

以下、各日の感想等々

事の経緯

3/17(土)に、 京都のはてな本社で行われた Kyoto.pm Tech Talks #1 に参加してきました。

セッション/トークやLTの内容については発表したした人たちがきっとreportしてくれるだろうからそれはそっちにまかせて、とりあえず印象深かったことをつらつらと

  • Yappoさん懐石料理食べてて遅刻
  • Job Queue Server と ORM の成分が多かった。
    • そういや今回Q4Mの名前を見かけなかったような..
    • DBICはめんどくさくてあまり使う気がしないけど、今度Teng辺り試してみるかなー
  • おやつ&LT はいいけど、配置には工夫の余地があるかも。(場所によってはとりづらいしみんな固まってるので移動もしづらい。。 まぁ、LT聞いとけよって話ですが
  • Pizza & Beer! (懇親会)
    • ビールにポップコーンを入れてはいけません
    • 体調が良くないときはお酒は控えめに
  • Xaicronさんが唐突に(?)東京から新幹線乗って懇親会終盤から参加&「ネタがない」と言いつつちゃんとトークやってくれてた。すげぇ

全体的に、Kansai.pmミーティングよりも参加者層が若いように感じられました。

Kyoto.pmはこれからもとりあえず3-4ヶ月スパンでのTech Talks開催を目指すそうですが、 技術的ないわゆる「勉強会」が頻繁に開催されるのは良いことですね。その内、何かネタがあれば 自分も何かしら発信していきたいなー、と、思ったり思わなかったり。

プログラミングの魔導書 vol.2 を読んでいたら、 SIPC の練習問題を引用されているところがあって、面白そうな問題なので挑戦してみた次第。

ちなみに問題は、

Exercise 4.42. Solve the following ``Liars'' puzzle (from Phillips 1934):

Five schoolgirls sat for an examination. Their parents -- so they thought -- showed an undue degree of interest in the result. They therefore agreed that, in writing home about the examination, each girl should make one true statement and one untrue one. The following are the relevant passages from their letters:

Betty: ``Kitty was second in the examination. I was only third.''
Ethel: ``You'll be glad to hear that I was on top. Joan was second.''
Joan: ``I was third, and poor old Ethel was bottom.''
Kitty: ``I came out second. Mary was only fourth.''
Mary: ``I was fourth. Top place was taken by Betty.''

What in fact was the order in which the five girls were placed?

4.3 Variations on a Scheme -- Nondeterministic Computing -- SIPC

こんなの。

そんなわけで回答してみる

昨日(10/14(Fir))から東京工業大学大岡山キャンパスで YAPC::Asia2011 が開催されていますが、昨日のLT Day 1にて、YAPC::Asia Tokyo 参加4年目にして初LTしゃべらせていただきました。あんな大勢の前で(っても照明のおかげでほとんど壇上からは見えてないけど)しゃべったのもはじめてなので、だいぶ緊張したし、色々不手際もあったかもしれませんが、聞いてくださった皆様ありがとうございました。 _o/L ヒラニー ヒラニー

使ったスライドは一応SlideShareに 上げてあります 。 (これまた初SlideShareだ!)

そんなわけで、今日2日目も楽しんできます。

既に Bug #64471 for AnyEvent-Twitter-Stream: JSON parsing errors としてRTには登録されていますが、

twitterのUserStreamを使うと JSON文字列の前に JSON文字列(+改行分?)長 のHEX文字列が入り込んでくることがあるみたいで(UserStreamのドキュメント見ても見つけられなかった、誰か知ってたら教えてください)、 AnyEvent::Twitter::Stream->new に no_decode_json => 1 を指定しておかないと HEX文字列が来たときに JSON::decode_json がcroak してしまい、UserStreamの読み込みが出来なくなってしまうようです。

んで、とりあえずやってきた文字列がJSONオブジェクトじゃなさそうな場合は読み飛ばすようにするパッチを作ってみた。

pull-requestとかは送ってない。

手動で「次へ」ボタンをカチカチやるのがいい加減めんどくさくなって作った。

※ 途中でエラーダイアログが出たらスクリプトをCtrl-Cで止めてから適切に対処してください ;)

ref:

近年、 perlbrew のおかげもあり、様々なバージョンのPerlを気軽にインストールできるようになってきたりしてますが、いざPerlをバージョンアップしたりすると、古い方のPerl環境にインストールしたモジュールを新しいPerl環境にもセットするのがめんどくさいものです。

そんなわけで、古いPerl環境にインストールされているモジュールを簡単に新しいPerl環境にインストールする方法について考えてみた。

去る 2010/05/15(Fri)-16(Sat) に東京工業大学大岡山キャンパスにて行われた Perlハッカー達の バカ騒ぎ 祭典。 YAPC::Asia Tokyo 2010 に参加してきました。

今年も参加者のPerlに対する熱い思いを感じられる良いYAPC::Asiaであったと思います。

代表の941さんを始め運営の方々、スタッフの方々、
今年も開催場所を提供してくださった東工大、
各スポンサー会社、
ゲストスピーカのLarry, Jesse, Miyagawaさん、
一般トークのスピーカの方々、そして一緒にあの楽しい場を作り上げたみんなにまずは感謝。

後、快く(?)行かせてくれた嫁にも感謝。

気になったセッション等は以下

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

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

どぞよろです。

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

手順1 まず 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を数えて」います。

.... ちゃんと?

コード例は上が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_utf8encode_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分もかかってないよ多分。

元ネタ

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

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

ざっと読んで(コード例は見てない) コード書いて、元ネタ3にあった例の検証が終わったのが 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' )
{
  /* 見つかったよ! */
}

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

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

http://codepad.org/mdisVGHM

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

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

一つは kuzuha さん作のもの。

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

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

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

共通点は、 MooseWeb::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

smilehappy の 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

CPANWWW::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 してみた。

答えが書いてあった \(^o^)/

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

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 LISTmap 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

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

ちょっと間が空きすぎですが、
過日行われた 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_sourcesxs_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.PLdmake 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 encodingSTDOUT => 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; });

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 threadsuse 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でしたが。)

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

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)は一体どれだ??

Round2はCollatz予想というものらしい. で、早速

#!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;
}
うむぅ、エレガントでない..
では、Language::Functionalモジュールを使ってみて、

#!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]);
}
....変わらねー T_T .
.
[追記]
よく考えたら f()は

sub f{
  my $n = shift;
  ($n % 2) ? $n*3+1 : $n/2;
}
で十分ですな。

[さらに追記]
もっと短くなった。わぁい(っても速度は変わらない(h(100000)で17.5秒くらい)けど)

#!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]})"

うん、多分完璧。

Acme::Oppai [Perl]

| コメント(0)
こーど:
#!/path/to/perl
use strict;
use Acme::Oppai;

print Acme::Oppai->Oppai;

じっこーけっか:
    _  ∩
  ( ゜∀゜)彡 おっぱい!おっぱい!
  (  ⊂彡
   |   | 
   し ⌒J





.... (o_ _)o…
こんなんでもちゃんとCPANやPPMに登録されてるんだよなぁ
主要使用モジュール
  • 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);

AUTHOR

  • turugina (虎王 剱奈)
  • E-mail: turugina {at} floralcompany.jp
  • pixiv
  • ニジエ

2014年5月

        1 2 3
4 5 6 7 8 9 10
11 12 13 14 15 16 17
18 19 20 21 22 23 24
25 26 27 28 29 30 31

アーカイブ

OpenID対応しています OpenIDについて
Powered by Movable Type 5.2.10

- 警 告 -

本サイトにはいわゆる「18禁画像」(イラスト)へのリンクが存在します。 未成年の方や、その手の画像に不快感を覚える方は、 該当記事(「えちぃの」及び「ちょっとえちぃの」カテゴリ) をご覧にならないようお願いいたします。

上記を理解した上で非表示のブログパーツを表示する
あわせて読みたいブログパーツ
ついった
drawr/pixiv/twitpic