JAMADAM.COM

[2009-08-15] バキューム機能つけた

2006年にpdumpfsっぽいPerlスクリプトを書いた。glastreeの存在は知っていたけど、敢えて自分で作ってみた。それ以来、仕事でもプライベートでも重宝していたんだけど、最近問題発生。職場のファイルサーバーには百万越えのファイル数があって、毎日数万の差分が発生し、バックアップに5時間かかっていた。こいつはまずいということで手直しした。結果、取りあえず、自宅では以前の10倍高速になった。

ちなみに、今回はglastreeのソースを追って参考にしてみたらほぼ同じ内容になってしまったんだけど、glasstreeとの違いは下記のとおり。

• バックアップの管理が日付に依存しないので任意の頻度(例えば２時間おきとか)で実行できる
• コピーされたログを残す
• コアモジュール以外に依存しない
• 差分がない場合はバックアップを自動削除

ログが残るってのはなかなか便利です。差分リスト=作業履歴なので。

使い方

perl ddump.pl [バックアップ対象] [保存場所]

バックアップポイントの数の上限を指定。あぶれた分は古い方から削除される。

perl ddump.pl --vacuum=400 [バックアップ対象] [保存場所]

ソース

use strict;
use warnings;
use utf8;
use English;
use Getopt::Long;
use File::stat;
use File::Copy;
use File::Path;

binmode(STDIN,  ":utf8");
binmode(STDOUT, ":utf8");
binmode(STDERR, ":utf8");
use open IO  => ":utf8";

use vars qw(%QUERY %stat_idx); # 設定
use vars qw($log $copy_count $file_count $symlink_count); # ログ関係変数
use vars qw($tgt_path $newdir $olddir); # ディレクトリ

main();

sub main {
    %stat_idx = ('mode' => 2, 'size' => 7, 'utime' => 9);

    %QUERY = ('mode' => 1, 'size' => 1, 'utime' => 1);
    GetOptions(\%QUERY, 'mode=s', 'size=s', 'utime=s', 'vacuum=i');

    ### 引数の整備と検証
    $ARGV[0] = &fixPath($ARGV[0]);
    $ARGV[1] = &fixPath($ARGV[1]);
    -d $ARGV[0] or die "$ARGV[0] not found";
    -d $ARGV[1] or die "$ARGV[1] not found";
    ### 引数を分離
    ($tgt_path, my $tgt_dir) = ($ARGV[0] =~ m!(.*)?/([^/]+)$!);

    if (opendir(DIR, "$ARGV[1]")) {
        my @dirs = sort grep{ -d "$ARGV[1]/$_" && /^\d+$/} readdir( DIR );
        close(DIR);
        ### 古いディレクトリを削除
        if ($QUERY{vacuum}) {
            for (my $i = 0; $i < $#dirs - $QUERY{vacuum}; $i++) {
                #print $dirs[$i] . " ";
                rmtree("$ARGV[1]/$dirs[$i]");
            }
        }

        ### 前回バックアップの時刻ディレクトリ名を取得
        $olddir = "$ARGV[1]/". (pop(@dirs) or '');
    }

    ### 時刻ディレクトリの作成
    my ($sec, $min, $hour, $mday, $mon, $year) = localtime($BASETIME);
    my $new_time =
        sprintf('%04d%02d%02d%02d%02d%02d', $year+1900, $mon+1, $mday, $hour, $min, $sec);
    $newdir = "$ARGV[1]/$new_time~";
    umask 0;
    mkdir($newdir, 0755) or die "cannnot make $newdir";

    ### ログファイル生成
    open($log, ">>$newdir/ddumplog.txt") or die "cannnot make log file";
    print $log <<EOF;
-----------------------------------------------------------------
-- ddump -- $new_time
-----------------------------------------------------------------
EOF

    ### ログ記録用変数
    $copy_count = 0;
    $file_count = 0;
    $symlink_count = 0;

    ### バックアップ
    &backup($tgt_dir);

    ### ログファイルに結果出力
    print $log "$copy_count/$symlink_count/$file_count (Copyed/symlink/Total)\n";
    print $log (time() - $BASETIME). "sec passed\n";
    close($log);

    if (! $copy_count) {
        ### コピーなしならディレクトリ削除
        rmtree($newdir);
    } else {
        ### ファイル名確定
        rename($newdir, substr($newdir, 0 ,length($newdir) - 1));
    }
}

### --------------------------------------------
### 再帰的ディレクトリバックアップ
### --------------------------------------------
sub backup {

    my $cwd = shift;
    my $tgt_cwd = "$tgt_path/$cwd";
    my $old_cwd = "$olddir/$cwd";
    my $new_cwd = "$newdir/$cwd";

    ### ディレクトリの作成
    &copydirstat($tgt_cwd, $new_cwd);

    ### カレントディレクトリ内の全ファイルを配列に格納
    opendir(DIR, $tgt_cwd) or return 0;
    my @files_and_dirs = readdir(DIR);
    close(DIR);

    my @files = grep { -f "$tgt_cwd/$_" or -l "$tgt_cwd/$_" } @files_and_dirs;

    ### @files_and_dirsのうち、ファイルを処理
    foreach my $a_file (@files) {
        my $old_file = "$old_cwd/$a_file";
        my $new_file = "$new_cwd/$a_file";
        my $tgt_file = "$tgt_cwd/$a_file";
        my $command = 1; # 0: nothing, 1: hard link 2: copy

        if (-l $tgt_file) {
            symlink(readlink($tgt_file), $new_file);
            $symlink_count++;
            $command = 0;
        }

        elsif (-f $old_file) {
            my $old_stat    = stat($old_file);
            my $crnt_stat   = stat($tgt_file);

            ### 更新ありならコピー
            foreach my $key (keys %stat_idx) {
                if ($QUERY{$key} and
                    $old_stat->[$stat_idx{$key}] ne $crnt_stat->[$stat_idx{$key}]) {

                    $command = 2;
                    last;
                }
            }
        } else { ### ファイルがなければコピー
            $command = 2;
        }

        ### コピー
        if ($command == 2) {
            copystat($tgt_file, $new_file);

            $copy_count++;

            ### ログ出力
            utf8::decode($new_file);
            print $log "$new_file\n";
        }

        ### ハードリンク
        elsif ($command == 1) {
            link($old_file, $new_file);
        }

        $file_count++;
    }

    ### @files_and_dirsのうち、ディレクトリを再帰処理
    my @dirs = grep { -d "$tgt_cwd/$_"
                    and not -l "$tgt_cwd/$_"
                    and $_ ne '.'
                    and $_ ne '..' } @files_and_dirs;

    foreach my $a_dir (@dirs) {
        &backup("$cwd/$a_dir") or print "Error at $cwd/$a_dir\n";
    }

    return 1;
}

### --------------------------------------------
### 属性丸ごとファイルコピー
### --------------------------------------------
sub copystat {
    my ($from, $to) = @_;
    my $stat = stat $from;

    copy($from, $to) or die "cannot copy $from to $to";
    chown($stat->uid, $stat->gid, $to) if $EUID == 0;
    chmod($stat->mode, $to);
    utime($stat->mtime, $stat->mtime, $to);
}

### --------------------------------------------
### 属性真似てディレクトリ作成
### --------------------------------------------
sub copydirstat {

    my ($from, $to) = @_;
    my $stat = stat $from;

    mkdir $to, 0555 or die "cannot mkdir $to";
    chown ($stat->uid, $stat->gid, $to) if $EUID == 0;
    chmod ($stat->mode, $to);
    utime ($stat->mtime, $stat->mtime, $to);
}

### --------------------------------------------
### ファイルパスの整備
### --------------------------------------------
sub fixPath {
    my $in = $_[0];
    $in =~ s!^!\./! unless ($in =~ m!^\.*/!);
    $in =~ s!/$!!;
    return $in;
}

連日、日付越えの激務のため趣味の開発などには全く身が入らない、なんていいつつ、ささやかな成果物。はてブ窓にコメントを表示するようにした。これのためにどうでもいいコメントもつけた。

関係ないけど、はてブatomfeedのofパラメータってなんであんな回りくどい仕様なんだろう。このブログでは必要なデータ取得するのに下記みたいなことをやってみたけど、使い方間違ってる？

var hatebu_epp = 20; // API固定の取得件数
var disp_epp = 5; // 例えば5件表示
var page = 5; // 例えば5ページ目を取得
var ppr = hatebu_epp / disp_epp; // 1リクエストで4ページ分
var request_offset = Math.floor((page - 1) / ppr) * hatebu_epp; // ofパラメータは20
var local_offset = Math.floor((page - 1) % ppr) * disp_epp; // 取得したデータ中のオフセットは0

非root権限でCPANモジュールを使う方法を調べた。Debian lenny(最小限のセットアップ)にて。2006年頃までにすべての情報が出尽くしてるのに何を今さら。

cpanの初期設定をする。設定項目「makepl_arg」はモジュールのインストール先ディレクトリ。PREFIX=~/perlと記載することで~/perl下に配置される。設定ファイルは下記のように書き換える。

$ vi ~/.cpan/CPAN/MyConfig.pm

- 'makepl_arg' => q[],
+ 'makepl_arg' => q[PREFIX=~/perl],

依存関係のあるモジュールを芋づる式にインストールするとき、後に入るモジュールのテストスクリプトが、直前の依存モジュールをincludeできなくてつまづく。これを回避するため、ユーザーの環境変数PERL5LIBにパスを設定する。~/.bashrcに下記を追記すれば楽。どうやらものによって下記のような2つのパスにインストールされるらしい。

$ vi ~/.bashrc

export PERL5LIB=~/perl/lib/perl/5.10.0:~/perl/share/perl/5.10.0

最初の「~/perl」は先ほどMyConfigのmakepl_argに追加したパス、それ以降は環境に依存するようなので一度失敗してみてパスを確認して再試行。もっといい方法ないのか。そのためのlocal::libなのかどうなのか、またの機会に調べてみよう。

参考サイト
一般ユーザ環境におけるCPANモジュールの使い方
Using CPAN with a non-root account

• TED.comは、最高レベルの英語学習コンテンツでは？
  去年、TED Talkで英語の勉強してたことがあったけど、サイトが尋常じゃなく重いのでやめてしまった。ニコラス・ネグロポンテとかゴア前副大統領とかが聞きやすくてよかった。ゴアさんは本題の環境問題に入る前までが面白い。あと英語の勉強なら動画内をテキストで検索できるGoogle Indexesも面白いかもしれない、と思いつつも全然利用はしてはいない。
• 英会話ドットネット、英会話SNSに位置情報で交流できる「Friend Map」追加
• 本を読んで分かった任天堂の「今そこにある危機」
  DSは参入障壁がハンパないときいた。是非間口を広げてほしい。
• ゼンリンの「道の駅」携帯サイトにトイレ情報追加
• 海外Webサイトを「Japanize」拡張を使って日本語で使う
• Android、OSは無償でも初期開発コストは想像以上に高い--HTC、HT-03A説明会を開催
• Twitterはまだまだ広告に対し慎重な態度を維持
• GENOウイルスに同人サイト連鎖感染　拡大防止へ協力の輪広がる
• Firefox 拡張を jQuery で書く！ Jetpack を使ってみた。
• 正しいマスクの使い方： 咳やくしゃみの人にそれを譲ってあげること
  専門家でさえ「マスクに予防効果があるという事実は立証されていない」と言うに留まっているのに「効果がない」とテレビやネットで断言する人がいるのは問題だ。とは言え、このエントリーのまとめはそれなりに説得力があった。飛沫感染と飛沫核感染を混同してる人の戯言とは一線を画する。ただし、この実験結果も示しているように、マスクの予防効果は無視できないと思う。濃厚接触時の予防効果については専門家も否定してないようだし、マスクをすることで無闇に呼吸器に手を触れないという効果もある。いずれにしても、この実験は十分「科学」してると思う。ちなみに僕は先週まではマスクしてたけど、もうしていない。ある程度自体が見えてきたので警戒を緩めるのは自然な流れ。

• 「大地震の時のお礼にマスク」台湾から兵庫・大阪へ
  こういうニュースは泣ける
• 「マスクで予防」過信は禁物　ウイルス、髪や服に
• 新型インフル、騒ぎ過ぎの代償
  「日本人ときたら」なんて言ってる日本人は5月初頭のBBCニュースが連日、日本同様の危機感をもって報道してたことを棚にあげるのか。
• なんと10倍のエネルギー量、世界初の「空気で充電できるバッテリー」が登場へ
• パナソニック、KDDIの2009年au夏モデルに端末を供給中止
  秋にはauでAndroidっていう解釈であってる？

TwitterでニュースFeedをフォローし出してからおもしろ記事がありすぎて全然追えない。

• jQueryを使ったWebポータルフレームワーク「JPolite」
• 便利！MS OfficeとGoogleドキュメントをコラボレートする「OffiSync」
• 「視聴率」「録画率」こんなに違う (ゲンダイネット)
• すっごく簡単にFirefoxのアドオンが作れてしまうMozilla Labsの『JetPack』がなんだか良さそうだ
• IVS Spring 2009開催--ミクシィ笠原氏ソーシャルアプリを語る

• Watch Live BBC News
• Box2DFlashAS3 の単純なサンプルと使い方 (2.0.2版)
• 自然な歌声を合成する産総研のVocaListener、世に出る
• 容量はBlu-rayの20倍、ついに500GBの記録容量を実現した「ホログラフィックディスク」が登場
• ハードディスクにおける容量の概念をひっくり返すDrobo

最近のコメント一覧のガジェットを、以前はサーバー側で長さ調整していたんですが、クライアント側で処理するように変更しました。これでユーザー環境に依存せずに最適なところで省略されるはず。ただし、文字サイズの変更とかガジェットの移動時に更新するとかの処理はまた今度。あと、例によって(どの例？)、IEでの動作検証は不十分です。

これのためにjqueryプラグインを作りました。改善の余地は大いにあり。

jquery.clipstr.js

使い方。widthは省略すると親のwidthに合わせてくれるかもしれない。

$('.boxsize_limited').limitCharWidth({
    width       : 220,
    instead_str : '...',
    set_title   : false
});

これ作ってて、関係ないところでハマった。上記の第二引数の後にカンマ入れてもFirefoxやSafariでは動くけどIE6,7で動かないらしい。なんでそんなところにカンマ入れるかと言えばメンテナンス性が向上するためで、Perlでは推奨されてたはず。

[2009.1.18追記]

少し直した。この機能のためにspanタグを自分で用意する必要があったのを改善。

[2009.1.19追記]

ちょっとバグってたので直した。

widthって指定させる必要があまりない気がしてきた。

[2009.1.23追記]

リサイズの検出の仕方がわからんなあ。とりあえず、元に戻せるようにunclipstrメソッドを追加。

$('.boxsize_limited').unlimitCharWidth();

[2009.1.28追記]

名前変えた。jquery.limitCharWidth.js。勇気を出してjQuery公式サイトにも登録してみようかな。

...つーかIE NetRendererで動いてねーし。ここ、たぶんスクリプトの読み込みに時間かかると無視されるから、実際の動作と必ずしも一致しないんだよなあ。やっぱマックのみではウェブ制作は無理だ。

...直ったっぽい。原因が2つあった。ひとつは、CSSのキーにはcss-prop(例えばfont-weight)とcssProp(例えばfontWeight)という2つの書式があって、jQueryのCSSメソッドでIEを相手にする場合はcssPropでないといけない（っぽい）。もうひとつは、IEのCSSでは多くのプロパティに対してinheritを指定することができなく、CSSメソッドでエラーが起きる(っぽい)。そんな訳で、inheritの代わりに、親の値を再指定することでinheritっぽいことをしてみた。けど、当初の目的を達成しているのか甚だ疑問。

[2009.2.1]

IE6でwidthを指定しない場合に動作していなかったのを改善。

ToDo

• 対象文字列が子要素を持つとたぶんバグるので対策。
• 内部で一時的に設置したspanが外のCSSの影響を受けないか検証。
• 自分自身がリサイズされたことを知る方法があるのか。あるなら自動更新機能。
• title属性使用の有無を引数で指定

先日から勉強がてら改造していたjqueryプラグインがひと段落したのでアップしてみる。その名もjquery.newtooltip.js。半分くらい原型をとどめてないので、もともとの機能が維持できてるか謎。特に、背景画像のIE対応とか未確認。世の中にはtooltipのjqueryプラグインはたくさんあるので、すでにいいものがあるのかも知れないです。あくまで勉強。

動作イメージはこちら。

下記のようにセットアップすると、title属性のあるタグは全部、マウスオーバーに反応するようになる。

// 一番簡単な使い方
$(document).ready(function(){
    
    $.tooltip_setup();
});

様々な初期設定。

// 様々な初期設定(下記はデフォルト)
$.tooltip_setup({
    in_json     : false,        // json書式を使用するか否か
    auto        : true,         // title属性から全自動で設定
    handler_on  : 'mouseover',  // tooltip表示用ハンドラ
    handler_off : 'mouseout',   // tooltip非表示用ハンドラ
    track       : true,         // mousemoveに追従する設定
    fade        : 200,          // フェード(msec)
    top         : 15,           // ポインタからの距離
    left        : 15,           // ポインタからの距離
    id          : "TOOLTIP"     // tooltip用id
    auto_css    : true,         // CSSをデフォルト値に設定
});

newtooltip.min.js
圧縮ファイル。

newtooltip.org.js
非圧縮ファイル。

Firefoxのプラグイン「Ubiquity」のコマンドラインから英辞郎で検索。解説はここを参照。リンク先のITmedia検索用コマンドをちょっと書き換えただけだけど。

makeSearchCommand({
    name: "alc",
    url: "http://eow.alc.co.jp/{QUERY}/UTF-8/",
    icon: "/favicon.ico",
    description: "Searches 英辞郎 on the WEB for your words.",
});

普通にここからxpiをDLしてインストール。Control + スペースでコマンドラインインターフェースが開くのでcommand-editorと入力すると新規タブにフォームが現れる。そこにコマンドのソースコードを入力(コピペ)すると保存などせずとも即、コマンドが有効になる。

あとはコマンドラインに下記のように入力するだけでwordという単語を検索できる。

alc word

なんかUbiquity自体の説明をまだよく読んでないんで、使い方がまだよく分からないんですが、どうやら「selection」と入力すると選択領域が引数に渡るらしい。

alc selection

 ちょっと前から思ってたんですが、英辞郎に昨年あたりからついたスペル修正候補の提案機能はすごく便利なんだけど、googleの「もしかして」機能よりは劣ってる。この点、Ubiquity使ったら連携してもっと便利になりそうな気がしてきた。

[2008/09/02追記]

選択領域を引数として渡すのにselectionは必要なかったらしい。検索系コマンドの場合は引数なければ自動的に選択領域が渡る。そりゃそうだよな。selectionなんて打つのは冗長すぎ。

最近、プライベートでPerlMagickを覚えたので、長文いれたら勝手に折り返してくれるPerlスクリプトを作ってみた。こんなものを動的に作って何になるのかってところは不明です。

先日のPHP+GDとほぼ同じ出力が得られるのに加えて、ストロークとドロップシャドウっぽいことをやるという余計な機能もつけてみた。PHP+GDよりえらく重いけど、Perl+Magickのがライブラリがいろんな機能に対応していて楽しい。

ソースコードも出しちゃう。汚いですけど。

package NT::Image::Magick::AnnotateWithLineBreak;
use strict;
use warnings;
use Image::Magick;
use Encode qw(decode);
use encoding 'utf8';

###  ------------------------------------------------------------------------------
### Constractor
###  ------------------------------------------------------------------------------
sub new {
    
    my $class = shift;
    my $self = 
        bless {
            magick => Image::Magick->new(), 
            charset => 'utf8', 
            ngCharactorsForHead => 
                ',)]｝、〕〉》」』】〟’”`≫。.・:;ヽヾーァィゥェォッャュョヮヵヶぁぃぅぇぉっゃゅょゎ', 
            ngCharactorsForTail => 
                '([｛〔〈《「『【〝‘“_≪', 
            ngCharactorsForSeparation => 
                '[a-zA-Z0-9¥'".,!¥?¥-]', 
            result => {width => 0, height => 0},
            @_
        }, $class;
    
    $self->Read($self->{file});
    
    return $self;
}

###  ------------------------------------------------------------------------------
### パラメータセットアップ
###  ------------------------------------------------------------------------------
sub setParam {
    
    my $self = shift;
    %$self = (%{$self}, @_);
}

###  ------------------------------------------------------------------------------
### メンバ変数magickにメソッドを委譲
###  ------------------------------------------------------------------------------
sub AUTOLOAD {
    
    no strict;
    my $self = shift;
    my $type = ref($self);
    my $name = $AUTOLOAD; $name =~ s/.*://;
    
    return $self->{magick}->$name(@_);
}

###  ------------------------------------------------------------------------------
### 文字入れ
### 戻り値：ハッシュリファレンス/要した幅と高さ
###  ------------------------------------------------------------------------------
sub breakLineAnnotate {
    
    my $self = shift;
    my %args = (
        x                       => 0,
        y                       => 0,
        width                   => undef,
        height                  => undef,
        pointsize               => 9,
        font                    => undef,
        text                    => '',
        fill                    => '#000000',
        'line-spacing'          => 4,
        'drop-shadow-depth'     => 0,
        'drop-shadow-color' => '#000000',
        'nice-stroke-width'     => 0,
        'nice-stroke-color'     => '#111111',
        @_);
    
    $args{width} = 
        (defined $args{width}) 
            ? $args{width} 
            : ($self->Get('width') - $args{x});
    
    $args{height} = 
        (defined $args{height}) 
            ? $args{height} 
            : ($self->Get('height') - $args{y});
    
    my $in_str = 
        utf8::is_utf8($args{text}) 
            ? $args{text} 
            : decode($self->{charset}, $args{text});
    
    $self->_putMultiLine(%args, text => $in_str);
    
    return $self->{result};
}

###  ------------------------------------------------------------------------------
### プリント
### 戻り値：整数/要した高さ
###  ------------------------------------------------------------------------------
sub _putMultiLine {
    
    my $self = shift;
    my %args = (@_);
    
    my $y_pos = $args{y};
    
    foreach my $line (split(/¥n/, $args{text})) {
        
        if (! $line) {
            
            $y_pos += $args{pointsize} + $args{'line-spacing'};
            next;
        }
        
        $y_pos = 
            $self->_putLogicalLine(
                %args, 
                text => $line, 
                y => $y_pos + $args{'line-spacing'}
            );
    }
    
    $self->{result}->{height} = $y_pos if ($y_pos > $self->{result}->{height});
    
    return $y_pos;
}

###  ------------------------------------------------------------------------------
### 論理行のプリント
### 戻り値：整数/要した高さ
###  ------------------------------------------------------------------------------
sub _putLogicalLine {
($__PACKAGE__::debugcount++ > 200) and $::gERROR->die(log => 'deep:'. $__PACKAGE__::debugcount);
    
    my $self = shift;
    my %args = (@_);
    
    $args{text} =~ s/^¥s//;
    
    my $pos1 = ($args{_last_length} or 1);
    my @box = 
        $self->QueryFontMetrics(%args, text => substr($args{text}, 0, $pos1));
    
    my $increment = ($box[4] > $args{width}) ? -1 : 1;
    
    ### Search for horizontal limit
    for (my $i = $pos1; $i > 0 and $i <= length($args{text}); $i += $increment) {
        
        @box = $self->QueryFontMetrics(%args, text => substr($args{text}, 0, $i));
        
        if ($increment == 1 and $box[4] > $args{width}) {
            
            last;
        }
        
        $pos1 = $i;
        
        if ($increment == -1 and $box[4] < $args{width}) {
            
            last;
        }
    }
    
    return $args{y} if (($args{y} + $box[5]) > $args{height});
    
    ### word wrapping
    if ($pos1 < length($args{text})) {
        
        while ($pos1 > 1) {
            
            my $next = substr($args{text}, $pos1, 1);
            
            if ($next and index($self->{ngCharactorsForHead}, $next) > -1) {
                
                $pos1--;
                next;
            } 
            
            my $last = substr($args{text}, $pos1 - 1, 1);
            
            if ($last and index($self->{ngCharactorsForTail}, $last) > -1) {
                
                $pos1--;
                next;
            }
            
            if ($last =~ /$self->{'ngCharactorsForSeparation'}/ and 
                $next =~ /$self->{'ngCharactorsForSeparation'}/) {
                
                $pos1--;
                next;
            }
            
            last;
        }
    }
    
    @box = $self->QueryFontMetrics(%args, text => substr($args{text}, 0, $pos1));
    $self->{result}->{width} = $box[4];
    $args{_last_length} = $pos1;
    
    my %args_common = (
        %args, 
        text    => substr($args{text}, 0, $pos1), 
        y       => ($args{y} + $box[5]), 
        );
    
    ### drop shadow
    for (my $i = 0; $i < $args{'drop-shadow-depth'}; $i++) {
        
        my %args_shadow = %args_common;
        
        if ($args{'nice-stroke-width'}) {
            
            $args_shadow{stroke} = $args{'drop-shadow-color'};
            $args_shadow{strokewidth} = $args{'nice-stroke-width'},
        }
        
        $self->Annotate(
            %args_shadow, 
            fill        => $args{'drop-shadow-color'},
            x           => $args_common{x} + 1, 
            y           => $args_common{y} + 1,
        );
    }
    
    ### stroke
    if ($args{'nice-stroke-width'}) {
        
        $self->Annotate(
            %args_common, 
            fill        => $args{'nice-stroke-color'},
            stroke      => $args{'nice-stroke-color'},
            strokewidth => $args{'nice-stroke-width'},
        );
    }
    
    ### Put text
    $self->Annotate(%args_common);
    
    ### Evaluate tail str
    if ($pos1 < length($args{text})) {
        
        return 
            $self->_putLogicalLine(
                %args, 
                y       => ($args{y} + $box[5] + $args{'line-spacing'}), 
                text    => substr($args{text}, $pos1)
            );
    }
    
    ### Returns bottom position of written box
    return $args{y} + $args{pointsize};
}

###  ------------------------------------------------------------------------------
### 結果取得
### 戻り値:interger/要した幅または高さ/
###  ------------------------------------------------------------------------------
sub getResult {
    
    return shift->{result}->{$_[0]};
}

return 1;

使い方。

my $image = 
    NT::Image::Magick::AnnotateWithLineBreak->new(
        file => 'source/heart_jamadam.png', charset => 'euc-jp');

$image->breakLineAnnotate(
    text                => 
        '最近、仕事でGDを覚えたので、長文いれたら勝手に折り返してくれるPHPスクリプトを作ってみた。日本語禁則処理もできそうだなあ。', 
    font                => 
        './font/mika.ttf', 
    pointsize           => 10,
    fill                => '#000000',
    x                   => 10,
    y                   => 80,
    width               => 231,
    height              => 260,
    'nice-stroke-width' => 1, 
    'nice-stroke-color' => '#ffffff',
    'drop-shadow-depth' => 0, 
    'drop-shadow-color' => '#000000',
);

$image->breakLineAnnotate(
    text                => '今すぐクリック', 
    font                => 
        './font/ipa/ipagp0208_for_legacy_compatibility.ttf', 
    pointsize           => 14,
    fill                => '#000000',
    width               => 251,
    height              => 260,
    x                   => 155,
    y                   => 130,
    'nice-stroke-width' => 6, 
    'nice-stroke-color' => '#fafffa',
    'drop-shadow-depth' => 0, 
    'drop-shadow-color' => '#000000',
);

my ($format, $mime) = $image->Get('magick', 'mime');

print 'Content-type: '. $mime. "¥n¥n";
binmode(STDOUT);
$image->Write($format. ':-');

[2008-5-27追記]
分割禁則というのにも、雰囲気だけ対応してみた。これで英文も概ね良好。

以前作ったサムネイルの自動生成CGIをモジュール化してみた。もともと小さなプログラムだったので、途中何度も「やる意味あんのか？」っていう、コンセプトレベルで結構悩んだ。でも結果的には割と理にかなった構造になった気がする。そして、前回書いたAUTOLOADによる継承委譲もつかってみた。

package NT::Image::Magick::Thumbnail;
use strict;
use warnings;
use Image::Magick;

### -----------------------------------------
### コンストラクタ
### -----------------------------------------
sub new {
    
    my $class = shift;
    my $self = {
        magick => Image::Magick->new,
        file => undef,
        cache_dir => undef,
        max_width => 800,
        max_height => 800,
        @_};
    
    bless $self, $class;
    $self->Read($self->{file});
    
    return $self;
}

### -----------------------------------------
### 継承をメンバ変数magickに適用
### -----------------------------------------
sub AUTOLOAD {
    
    no strict;
    my $self = shift;
    my $type = ref($self);
    my $name = $AUTOLOAD; $name =~ s/.*://;
    
    return $self->{magick}->$name(@_);
}

### -----------------------------------------
### 画像リサイズ & キャッシュ出力
### -----------------------------------------
sub make {
    
    my $self = shift;
    my %args = (
        width => 0, 
        height => 0, 
        @_);
    
    if (my $cache_name = $self->cacheExists(%args)) {
        
        $self->Read($cache_name);
    }
    
    else {
        
        my ($width, $height) = $self->Get('width', 'height');
        
        ### 引数取得
        my $target_width = ($args{width} or 0);
        my $target_height = ($args{height} or 0);
        
        ### アスペクト比保持
        $target_height  ||= ($height * $target_width) / $width;
        $target_width   ||= ($width * $target_height) / $height;
        
        ### 上限判定
        $target_width = $self->{max_width} if ($target_width > $self->{max_width});
        $target_height = $self->{max_height} if ($target_height > $self->{max_height});
        
        ### 四捨五入と0回避
        $target_width = (int($target_width + 0.5) or 1);
        $target_height = (int($target_height + 0.5) or 1);
        
        ### リサイズ
        $self->Resize(width => $target_width, height => $target_height);
        
        ### キャッシュ出力
        if ($self->{cache_dir}) {
            
            my $cache_name = $self->getCacheName(%args);
            
            if (open(CACHE, "> ". $cache_name)) {
                
                binmode(CACHE);
                $self->Write(file => ¥*CACHE, filename => $cache_name);
                close(CACHE);
            }
        }
    }
}

### -----------------------------------------
### キャッシュ存在確認
### -----------------------------------------
sub cacheExists {
    
    my $self = shift;
    my %args = (
        width => 0, 
        height => 0, 
        @_);
    
    my $name = $self->getCacheName(%args);
    return (-e $name) ? $name : undef;
}

### -----------------------------------------
### キャッシュ名を得る
### -----------------------------------------
sub getCacheName {
    
    my $self = shift;
    my %args = (
        width => 0, 
        height => 0, 
        @_);
    
    if ($self->{cache_dir}) {
        
        my $new_query = '';
        $new_query = ($args{width}) ? 'x='. $args{width} : '';
        $new_query .= ($args{height}) ? '&y='. $args{height} : '';
        $new_query =~ s/^&//;
        
        my ($name, $ext) = ($self->{file} =~ /^(.+)¥.([^.]+)$/);
        return sprintf("%s/%s.%s.%s", $self->{cache_dir}, $name, $new_query, $ext);
    }
    
    return;
}

return 1;

使い方

#!/usr/bin/perl -w

### -----------------------------------------
### 初期設定
### -----------------------------------------
my $org_dir = '';
my $cache_dir = 'cache';
my $max_width = 800;
my $max_height = 800;
### -----------------------------------------

use strict;
use warnings;
use NT::Image::Magick::Thumbnail;
use CGI;

my $q = new CGI(); 

my %args = (
    width => scalar $q->param('x'), 
    height => scalar $q->param('y'));

### ソース
my $org_path = $org_dir. './'. $q->param('f');
-e $org_path or die 'file not found';

my $image = 
    NT::Image::Magick::Thumbnail->new(
        file => $org_path, 
        cache_dir => $cache_dir,
        max_width => $max_width, 
        max_height => $max_height
    );

if (! &binary_out($image->getCacheName(%args), $image->Get('mime'))) {
    
    $image->make(%args);
    
    my ($format, $mime) = $image->Get('magick', 'mime');
    
    ### ヘッダ出力
    print 'Content-type: '. $mime. "¥n¥n";
    
    binmode(STDOUT);
    $image->Write($format. ':-');
}

exit(0);

### -----------------------------------------
### 汎用バイナリ出力
### -----------------------------------------
sub binary_out {
    
    if (open(IN, $_[0])) {
        
        print "Content-Type: $_[1]¥n¥n";
        
        binmode(IN);
        binmode(STDOUT);
        
        read(IN, my $buf, -s $_[0]);
        print $buf;
        close(IN);
        
        return 1;
    }
    
    return 0;
}

以前書いたとおりのhtaccessを使えば、2回目以降CGIの起動がないので速いです。

ちなみに、このサンプルコードのために生まれて初めてCGI.pmを使ってみた。やっぱ、あるものは使うべきなのか。

[2008/05/16追記]

モジュールのほうでキャッシュ機能を活用してるので、実はこれだけでよかったりする。

#!/usr/bin/perl -w

### -----------------------------------------
### 初期設定
### -----------------------------------------
my $org_dir = '';
my $cache_dir = 'cache';
my $max_width = 800;
my $max_height = 800;
### -----------------------------------------

use strict;
use warnings;
use NT::Image::Magick::Thumbnail;
use CGI;

my $q = new CGI();

my $org_path = $org_dir. './'. $q->param('f');
-e $org_path or die 'file not found';

my $image = 
    NT::Image::Magick::Thumbnail->new(
        file => $org_path, 
        cache_dir => $cache_dir,
        max_width => $max_width, 
        max_height => $max_height
    );

$image->make(
    width => scalar $q->param('x'), 
    height => scalar $q->param('y'));

my ($format, $mime) = $image->Get('magick', 'mime');
print 'Content-type: '. $mime. "¥n¥n";
binmode(STDOUT);
$image->Write($format. ':-');

exit(0);