12:46 アイコン(サムネイル)を作るモジュール

ImageMagickでAnimated GIFのサムネイルをきれいにつくる方法 : blog.nomadscafe.jpのオマケ

package Iconizer;

use strict;
use warnings;
use base qw/Class::Accessor::Fast/;
use IPC::Run;
use File::Copy;

__PACKAGE__->mk_accessors(
    qw/input size output width height frames/
);

sub do_identify {
    my $self = shift;
    my %identify;
    my $h = IPC::Run::start(
        [
            '/usr/bin/identify',
            $self->input
        ],
        map { \$identify{$_} } qw/in out error/
    );
    my $identify = $h->finish;
    die "identify failed: $identify{error}\n" unless $identify;
    my @identify = split /\n/, $identify{out};
    $self->frames(scalar @identify);
    if ( $identify[0] =~ / \d+x\d+ (\d+)x(\d+)\+\d\+\d/ ) {
        $self->width($1);
        $self->height($2);
    }
    elsif ( $identify[0] =~ / (\d+)x(\d+) / ) {
        $self->width($1);
        $self->height($2);
    }
    else {
        die "cannot identify file\n";
    }

}

sub do_convert {
    my $self = shift;

    my $resize_height = $self->size;
    my $resize_width = $self->size;
    if ( $self->width > $self->height ) {
        $resize_width = int ($self->width * $self->size)/$self->height; 
    }
    else {
        $resize_height = int ($self->height * $self->size)/$self->width; 
    }
    $resize_width ||= 1;
    $resize_height ||= 1;
    
    my $top=0;
    my $left=0;
    if ( $resize_width > $resize_height ) {
        $left = int ($resize_width - $self->size)/2;
    }
    else {
        $top = int ($resize_height - $self->size)/2;
    }

    my %convert;
    my $h = IPC::Run::start(
        [
            '/usr/bin/convert',
            '-size',
            $self->width . "x" . $self->height,
            $self->input,
            '-coalesce',
            '-resize',
            $resize_width . "x" . $resize_height,
            '-sharpen',
            '1',
            '-crop',
            sprintf("%sx%s+%s+%s", $self->size,$self->size,$left,$top),
            '+repage',
            '-deconstruct',
            $self->output
        ],
        map { \$convert{$_} } qw/in out error/
    );
    my $convert = $h->finish;
    die "convert failed: $convert{error}\n" unless $convert;
    my $ext;
    my $name;
    if ( $self->output =~ /\.([^.]+)$/ ) {
        $name = $`;
        $ext = $1;
    }
    if ( -f "$name-0.$ext" ) {
        File::Copy::copy("$name-0.$ext", $self->output);
        for(my $i=0;$i<$self->frames;$i++){
            unlink "$name-$i.$ext";
        }
    }
}

package main;

my $icon = Iconizer->new({
    input => "input.gif",
    output => "output.gif",
    size   => 32
})
$icon->do_identify;
$icon->do_convert;

21:31 Cache::Memcached 1.21 その3

buck2sockを使わないようにしてみた

--- Cache-Memcached-1.21.orig/lib/Cache/Memcached.pm    2007-05-03 07:06:59.000000000 +0900
+++ Cache-Memcached-1.21/lib/Cache/Memcached.pm 2007-05-10 21:08:55.000000000 +0900
@@ -162,12 +162,12 @@
 
 sub _dead_sock {
     my ($sock, $ret, $dead_for) = @_;
-    if (my $ipport = $sock_map{\$sock}) {
+    if (my $ipport = $sock_map{$sock}) {
         my $now = time();
         $host_dead{$ipport} = $now + $dead_for
             if $dead_for;
         delete $cache_sock{$ipport};
-        delete $sock_map{\$sock};
+        delete $sock_map{$sock};
     }
     @buck2sock = ();
     return $ret;  # 0 or undef, probably, depending on what caller wants
@@ -175,10 +175,10 @@
 
 sub _close_sock {
     my ($sock) = @_;
-    if (my $ipport = $sock_map{\$sock}) {
+    if (my $ipport = $sock_map{$sock}) {
         close $sock;
         delete $cache_sock{$ipport};
-        delete $sock_map{\$sock};
+        delete $sock_map{$sock};
     }
     @buck2sock = ();
 }
@@ -563,8 +563,8 @@
             my $tries;
             while (1) {
                 my $bucket = $hv % $bcount;
-                $sock = $buck2sock[$bucket] ||= $self->sock_to_host($self->{buckets}[ $bucket ])
-                    and last;
+                $sock = $self->sock_to_host($self->{buckets}[ $bucket ]);
+                last if $sock;
                 next KEY if $tries++ >= 20;
                 $hv += _hashfunc($tries . $real_key);
             }

19:09 Cache::Memcached 1.21続き

まだまだ怪しい

[Thu May 10 16:09:46 2007] [error] No map found matching for UNKNOWN(0xbb3c814) at /usr/lib/perl5/vendor_perl/5.8.8/Cache/Memcached.pm line 658, <DATA> line 1.\n
[Thu May 10 16:09:47 2007] [error] No map found matching for SCALAR(0xbf86c34) at /usr/lib/perl5/vendor_perl/5.8.8/Cache/Memcached.pm line 658, <DATA> line 1.\n
[Thu May 10 16:09:48 2007] [error] No map found matching for UNKNOWN(0xb7932d4) at /usr/lib/perl5/vendor_perl/5.8.8/Cache/Memcached.pm line 658, <DATA> line 1.\n
Use of uninitialized value in string eq at /usr/lib/perl5/vendor_perl/5.8.8/Cache/Memcached.pm line 423, <DATA> line 1.

こんなログがでて死にます

14:25 Cache::Memcached 1.21

--- Cache-Memcached-1.21.orig/lib/Cache/Memcached.pm    2007-05-03 07:06:59.000000000 +0900
+++ Cache-Memcached-1.21/lib/Cache/Memcached.pm 2007-05-10 13:55:11.000000000 +0900
@@ -162,12 +162,12 @@
 
 sub _dead_sock {
     my ($sock, $ret, $dead_for) = @_;
-    if (my $ipport = $sock_map{\$sock}) {
+    if (my $ipport = $sock_map{$sock}) {
         my $now = time();
         $host_dead{$ipport} = $now + $dead_for
             if $dead_for;
         delete $cache_sock{$ipport};
-        delete $sock_map{\$sock};
+        delete $sock_map{$sock};
     }
     @buck2sock = ();
     return $ret;  # 0 or undef, probably, depending on what caller wants
@@ -175,10 +175,10 @@
 
 sub _close_sock {
     my ($sock) = @_;
-    if (my $ipport = $sock_map{\$sock}) {
+    if (my $ipport = $sock_map{$sock}) {
         close $sock;
         delete $cache_sock{$ipport};
-        delete $sock_map{\$sock};
+        delete $sock_map{$sock};
     }
     @buck2sock = ();
 }

15:52 fc4のlibgtop2-devel-2.10.1-1にopen.hがない

fc4でperlのGTopのinstallが

/usr/include/libgtop-2.0/glibtop/open.h

がないと怒られてできない。

とりあえず、libgtop2-2.10.2のrpmを作ってupdate。

23:19 Net::SSH::Perlで使えるオプション

Net::SSH::Perlで使えるオプション

%DIRECTIVES = (
    BindAddress             => [ \&_set_str, 'bind_address' ],
    Host                    => [ \&_host ],
    BatchMode               => [ \&_batch_mode ],
    ChallengeResponseAuthentication => [ \&_set_yesno, 'auth_ch_res' ],
    Cipher                  => [ \&_cipher ],
    Ciphers                 => [ \&_set_str, 'ciphers' ],
    Compression             => [ \&_set_yesno, 'compression' ],
    CompressionLevel        => [ \&_set_str, 'compression_level' ],
    DSAAuthentication       => [ \&_set_yesno, 'auth_dsa' ],
    GlobalKnownHostsFile    => [ \&_set_str, 'global_known_hosts' ],
    HostKeyAlgorithms       => [ \&_set_str, 'host_key_algorithms' ],
    HostName                => [ \&_set_str, 'hostname' ],
    IdentityFile            => [ \&_identity_file ],
    NumberOfPasswordPrompts => [ \&_set_str, 'number_of_password_prompts' ],
    PasswordAuthentication  => [ \&_set_yesno, 'auth_password' ],
    PasswordPromptHost      => [ \&_set_yesno, 'password_prompt_host' ],
    PasswordPromptLogin     => [ \&_set_yesno, 'password_prompt_login' ],
    Port                    => [ \&_set_str, 'port' ],
    Protocol                => [ \&_protocol ],
    RhostsAuthentication    => [ \&_set_yesno, 'auth_rhosts' ],
    RhostsRSAAuthentication => [ \&_set_yesno, 'auth_rhosts_rsa' ],
    RSAAuthentication       => [ \&_set_yesno, 'auth_rsa' ],
    UsePrivilegedPort       => [ \&_set_yesno, 'privileged' ],
    User                    => [ \&_set_str, 'user' ],
    UserKnownHostsFile      => [ \&_set_str, 'user_known_hosts' ],
);

17:12 FC5 FC6でPerlが遅い問題

とりあえず、解決っぽ

Perl-5.8.8-5以降だとこの問題がおきる。

Bugzilla Bug 196836: perl-5.8.8-5 is 30X slower than perl-5.8.8-4

#34925: overload and rebless

FedoraがあてたPatch

  • perl-5.8.8-U27509.patch
  • perl-5.8.8-U27512.patch

が原因なのでspecファイルいじってrebuild

--- perl.spec.orig      2006-12-28 17:10:59.000000000 +0900
+++ perl.spec   2006-12-28 13:52:19.000000000 +0900
@@ -160,8 +160,8 @@
 Patch27116:    perl-5.8.8-U27116.patch
 Patch27391:     perl-5.8.8-U27391.patch
 Patch27426:    perl-5.8.8-U27426.patch
-Patch27509:     perl-5.8.8-U27509.patch
-Patch27512:     perl-5.8.8-U27512.patch
+#Patch27509:     perl-5.8.8-U27509.patch
+#Patch27512:     perl-5.8.8-U27512.patch
 Patch27604:     perl-5.8.8-U27604.patch
 Patch27605:     perl-5.8.8-U27605.patch
 Patch27914:     perl-5.8.8-U27914.patch
@@ -367,9 +367,9 @@
 
 %patch27426 -p1
 
-%patch27509 -p1
+#%patch27509 -p1
 
-%patch27512 -p1
+#%patch27512 -p1
 
 %patch27604 -p1

極端に遅くなる処理のベンチ例みたいなのがほしいかな

20:27 cpan2rpm Encode::EUCJPMS

エラー: Installed (but unpackaged) file(s) found:
   /usr/lib/debug/usr/lib/perl5/site_perl/5.8.6/i386-linux-thread-multi/auto/Encode/EUCJPMS/EUCJPMS.so.debug
   /usr/src/debug/Encode-EUCJPMS-0.07/EUCJPMS.c
   /usr/src/debug/Encode-EUCJPMS-0.07/EUCJPMS_t.c
   /usr/src/debug/Encode-EUCJPMS-0.07/EUCJPMS_t.exh
   /usr/src/debug/Encode-EUCJPMS-0.07/EUCJPMS_t.h

だったので、

$ tar zxf Encode-EUCJPMS-0.07.tar.gz 
$ cd Encode-EUCJPMS-0.07
$ perl Makefile.PL
$ make
$ make manifest
$ make dist
$ cpan2rpm Encode-EUCJPMS-0.07.tar.gz

で、できた。

21:21 String::Random

alias stringrandom="perl -MString::Random -e 'print String::Random->new->randregex(@ARGV),qq(\n)'"

21:56 Net::SSH::Perlでstdin

20KBぐらいのstdinを送ると返事が返ってこなくなる。

うーん

< 1 2 3 4 >