Perlでバイナリファイルをいじる場合にいろいろと同じ問題に遭遇するので、忘れないようにメモ。

バイナリファイルの読み込み

読み込む場合に”getc”使うと、ファイルが終わってないのに終了してしまうことがある。
正しくは”read”を使う。

my $filename = $ARGV[0];
open my $file,'<',$filename or die;
binmode $file; 
my $val;
while(read($file, $val, 1)){
}

これで1byteづつ処理できる。実際はバイナリの構造にあわせてreadするバイト数を変える。

読んだバイナリの処理

バイナリを数値として処理するためには、その構造にあわせてunpackする。

unpack("C",$val); #unsigned byte
unpack("S",$val); #unsigned short
unpack("L",$val); #unsigned long
unpack("c",$val); #signed byte
unpack("s",$val); #signed short
unpack("l",$val); #signed long

bit処理の場合は、いろいろ問題がある。
ビット反転”~”は、ビット長にあわせてpackしてから処理する。

~pack("c",$i); # $iは数値。一旦byteにしてからビット反転

ビットの”&(and),|(or),^(xor)”は、両方同じビット長にする。
もしくはunpackしてから処理する(unpackしても同じビット長(環境依存)になるからね)

pack("s",$j) ^ pack("s",$i); # $i,jは数値。両方shortにしている
unpack("s",$val) ^ $i; # $valは読んだバイナリ,$iは数値。

ビットシフト”«”, “»“は、数値化(unpack)してからじゃないと動かない。。。(何故？)

unpack("S",$i) << 1

と、いうことで、実は「ビット反転」以外はunpackして処理する。ということ。
例として、μ-lawとPCMの変換(なんのこっちゃ？という人はwavファイルの勉強を。。)

my $mantissa = unpack("C",~$val); #$valが読み込んだバイナリ
my $sign = (unpack("C",$val) < (0x0080))? -1:1;
my $exponent = ($mantissa >> 4) & (0x0007);
my $segment = $exponent + 1;
$mantissa = $mantissa & (0x000F);
my $step = (0x0004) << $segment;
my $g191_value = pack("S",$sign * (((0x0080) << $exponent) + $step*$mantissa + $step/2 - 4*33));
#最後に"S"でpackしてunsigned shortに

バイナリの書き出し

書き出したい構造にあわせてpackしてやる。
wavファイルのヘッダとかだとこうなる。

my $form = "";
$form .= "RIFF";
$form .= pack("L",$size + 36); #data size + headersize(-8) 
$form .= "WAVE";
$form .= "fmt ";
$form .= pack("L",16); #fmt chunk size
$form .= pack("S",1); # pcm
$form .= pack("S",1); # mono
$form .= pack("L",8000); # 8k sampling
$form .= pack("L",16000); # Byte/sec = sampling * 2byte(16bit 量子化) * 1(mono)
$form .= pack("S",2); # Byte/sample(8bit量子化) * channel(mono)
$form .= pack("S",16); # 8bit量子化
$form .= "data";
$form .= pack("L",$size); #data size

おまけ

signedとunsignedを変換するにはpackしてunpackというややこしい方法が必要。

my $i = -100;  
my $unsigned_value = unpack("C",pack("c",$i));  

wav関連でもぞもぞしてるのバレバレですね。

以下の方法では動かない。

package hoge; 
sub new{
  my $class=shift;
  my $self={'msg2' => 'harahoro','hoge' => \&hoge};
  bless $self,$class;
  return $self;
} 
sub fuga{
  my $self=shift;
  my $msg =shift;
  my $classname=ref $self;
  print "from $classname : hello! $msg\n"; 
} 
sub hoge{
  my $self=shift;
  my $msg = shift;
  print "I am calling fuga\n";
  $self->fuga("hoge : $msg and ". $self->{"msg2"});
} 
1;
package main; 
my $moga=hoge->new;
$moga->{'hoge'}->('self hash'); 

当然、以下も動かない。

package hoge; 
sub new{
  my $class=shift;
  my $self={'msg2' => 'harahoro'};
  bless $self,$class;
  $self->init;
  return $self;
} 
sub init{
  my $self=shift;
  $self->{"hoge"} = \&hoge;
} 
sub fuga{
  my $self=shift;
  my $msg =shift;
  my $classname=ref $self;
  print "from $classname : hello! $msg\n"; 
} 
sub hoge{
  my $self=shift;
  my $msg = shift;
  print "I am calling fuga\n";
  $self->fuga("hoge : $msg and ". $self->{"msg2"});
} 
1;
package main; 
  my $moga=hoge->new;
  $moga->{'hoge'}->('self hash'); 

以下の２点が問題

• $self->funcのリファレンス取得方法がない
• \&funcとするとinvocantが渡らない

なので、以下のような解決方法になる。

package hoge;
sub new{
  my $class=shift;
  my $self={'msg2' => 'harahoro'};
  bless $self,$class;
  $self->init;
  return $self;
} 
sub init{
  my $self=shift;
  $self->{"hoge"} = $self->hoge_invocant;
} 
sub fuga{
  my $self=shift;
  my $msg =shift;
  my $classname=ref $self;
  print "from $classname : hello! $msg\n"; 
} 
sub hoge_invocant{
  my $invocant=shift;
  return sub {  hoge($invocant, @_);};
} 
sub hoge{
  my $self=shift;
  my $msg = shift;
  print "I am calling fuga\n";
  $self->fuga("hoge : $msg and ". $self->{"msg2"});
} 
1;
package main; 
my $moga=hoge->new; 
$moga->{'hoge'}->('self hash');

hoge_invocantが
「invocantをレキシカルクロージャとして保持しhogeをinvocantつきで呼び出す無名関数」
を返す。
ここで無名関数を使うべきだということに気付いた。

sub init{
  my $self=shift;
  $self->{"hoge"} = sub {hoge($self, @_);};
}

追記～～
<iframe id=”4873112036”src=”http://motivation.drivendevelopment.jp/amazon_query_proxy/queryproxy_ruby.cgi?ItemId=4873112036” onload=”fitFrame(this.id)” frameborder=”0” width=”100%”></iframe>
本屋で↑を立ち読みしたら(買え！　＞＞ 俺) 載ってた。
同じ結論になってたようなので、買わなくてもいいってことか？
～～追記終わり

Perlは、内部的に改行をLFとして扱い、入力時・出力時に環境に合わせたコードで出力する。
なので、Windows上のperl (Strawberry perl使用)で、以下のようにすると

perl -e 'print "\x0a";'

出力に 0x0d0a (CR+LF)がでてしまう。

Windows環境でもLFで出したい時もある。
そのときは、こうしなければならないみたい。

perl -e 'binmode STDOUT; print "\x0a";'

$/とか$\とかいろいろいじったけど、できなかった。

multipart/mixedのメールが複数分割されて送られてきました。メール本文は空っぽで、全て添付ファイルになっていました。
どうやら、outlook expressで送信した場合に起こる現象のようですが、こちらで読めないので困ってしまいます。

中身を見ると、テキストの本文に続き、

Content-Type: application/octet-stream;
Content-Transfer-Encoding: base64

となっていて、この部分以降に怪しげな文字列が延々と続いています。

この部分以降は、base64でエンコードされたバイナリ添付ファイルなわけです。

この部分を取り出してエンコードを解けば(デコードすれば)、添付されていたファイルを復活できるはずです。

で、perlの出番です。

Step1:base64部分だけのファイルを作る

> ls
xxx[1_3].dat
xxx[2_3].dat
xxx[3_3].dat
> cat *.dat > abc.dat
> vim abc.dat
#ここで、必要な部分(怪しげな文字列の部分)以外を削除

Step2: perlでデコード
Perlのソース

#!/usr/bin/perl -w
use MIME::Base64;
binmode STDOUT,'raw';
binmode STDIN,'raw'; 
while(<>){
  print decode_base64($_);
}

楽勝だね。

あいかわらず、初歩的なところにいます。。。(-_-;)
perlのCGIでアクセス解析のためにリファラ(訪れた人が前に見ていたページ)を取ろうとしてたのですが、検索サイトによって文字が化けたりしてたので、utf8に統一してみようということで、以下のようにしました。

• ページに埋め込むjavascript

<script language="JavaScript">
  <!--
    document.write('<img src="http://hoge.fuga.funya/access.cgi?rr=' + escape(document.referrer) + '" />');
  // -->
</script>

imgタグ内でアクセス解析用のcgiを呼んでいます。cgi側でHTTP_REFERERを取ると、このスクリプトを入れたページ自身になるので、パラメータとしてrrにリファラを入れています。

• cgi側(perl)

#!/usr/bin/perl -w
use strict;
use CGI;
use Encode;
use Encode::Guess qw/euc-jp shiftjis 7bit-jis/;
use utf8; 

my $file="access.log";

my $q=new CGI;
my $ref = url_decode($q->param('rr')); #前のページ
my $referer = url_decode($q->referer()); #見られてるページ

my $result="\"$ref\",\"$referer\"\n";

open(FILE,">>:encoding(utf8)", $file) or error($q, "can't open");
print(FILE $result);
close(FILE); 

&printimg;
exit;
 
sub url_decode{
  my $str = shift;
  return 'hoge' unless $str;
  $str =~ tr/+/ /;
  $str =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/pack('H2', $1)/eg;
  my $decoder = Encode::Guess->guess($str);
  return $decoder->decode($str) if(ref($decoder));
  return decode("utf8",$str);
}
sub printimg{
  open(COUNTERIMG, "./counter.gif") or error($q, "can't open");
  binmode(COUNTERIMG);
  print "Content-type: image/gif\n\n";
  print <COUNTERIMG>;
  close(COUNTERIMG);
}

urlエンコードされた文字を一旦もどしてからEncode::Guessでデコードしてファイルに書き込んでいます。
これにより、文字コードが統一されます。

urlエンコードをデコードするときにpackを利用しているのでutf8フラグ関係が心配なので、utf8フラグをつける前にurlデコードしています。

最後にimgを転送して終了。
なんか美しくないけど、動く。

言語によっていろいろ違うなぁと実感。
Perl

use Encode;

binmode STDOUT, ":encoding(shiftjis)"; 

my @str = qw(00110000 01000010);
my $final = join('',map{pack('B8',$_)} @str);
$final = decode('UTF-16BE',$final); 
print $final;

Perlのmap関数の使い勝手は最強ですね。

java

import java.io.*; 

public class BinaryDecode{
  public static void main(String[] args) {
    String[] strArray = {"00110000","01000010"};
    byte[] bytes = new byte[2];
    int i = 0;
    for(String s : strArray){
      int j = Integer.parseInt(s,2);
      if(j > 127){ j = j - 256;} //-128～127に収める処理
      bytes[i++] = (byte)j;
    }
    try{
      System.out.println(new String(bytes,"UTF-16BE"));
    }catch(IOException e){
      e.printStackTrace();
    }
  }
}

javaの場合、文字列が可変長の場合、”byte[]”の代わりに”List"を使う必要が出てきてさらにややこしくなる。 また、javaでは、Byte.parseByteは、内部的にIntegerに変換して128以上だとエラー出すので、しょうもない処理が必要。

便利なワンライナー

grep -r -l xxxxx . | xargs perl -pi.bak -e "s/xxxxx/yyyyy/g"

xxxxxの含まれているファイルを抽出して、中身のxxxxxをyyyyyに書き換え。
バックアップファイルとして.bakを作成

FizzBuzzってはやってたけど、３の倍数と３の付く数字でアホになる場合はどうなるかやってみた。

perl -e'print+(aho)[$_%3 and (/3/)?0:1]||$_,$/for 1..100'

もっと短くなるのだろうか。。。


参考:
FizzBuzz - Golf Challenge


追記: ３項演算子いらないみたい。

perl -e'print+(aho)[$_%3 and !/3/]||$_,$/for 1..100'

テンプレート内に日本語を書くと文字化けする。
utf-8がTemplateで読まれるときのフラグの関係だと思われる。
いろいろ調べてTemplate::Provider::Encodingという、かの有名なmiyagawaさんのモジュールを使えば良いことがわかった。

Index: Chariot.pm
===================================================================
--- Chariot.pm	(revision 13330)
+++ Chariot.pm	(working copy)
@@ -7,6 +7,7 @@
 use YAML;
 use App::Chariot::Config;
 use Template;
+use Template::Provider::Encoding;
 use File::Spec;
 use XML::RSS;
 use Scalar::Util;
@@ -55,9 +56,11 @@
         my $self = shift;
         Template->new(
             {
+                LOAD_TEMPLATES => [ Template::Provider::Encoding -> new({
                 INCLUDE_PATH =>
                   File::Spec->catfile( $self->config->assets_dir, 'tmpl' ),
                 ABSOLUTE => 1,
+                })]
             }
         );
     }

実は、このサイトがずっと英語メニューだったのはこのためだったのだ。:-p

タグ別アーカイブに対応した。(但し、複数タグの絞込みはできない。)
複数タグでの絞り込みは、オンラインアーキテクチャじゃないと厳しそうなので。。

package App::Chariot::C::TagIndex;
use Moose;
with 'App::Chariot::Role::C';

sub create {
    my ($self, $c) = @_;

    my $ifile = File::Spec->catfile($c->config->assets_dir, 'tmpl', 'tagindex.tt');
    my %tags = ();
    for my $entry (@{$c->dat->list}) {
        for my $item (reverse @{$entry->items->list}) {
            for my $t (@{$item->tags}){
                $tags{$t} = [] unless $tags{$t};
                unshift(@{$tags{$t}},$item);
            }
        }
    }
    for my $t (keys %tags){
        my $cnt =1;
        my @list = @{$tags{$t}};
        my $ofile = File::Spec->catfile($c->config->output_dir, "$t.html");
        $c->render(
            $ifile => $ofile, {
                tag => "[$t]",
                items  => [@list],
            },
        );
    }
}

1;

App::Chariotのコントローラ群にApp::Chariot::C::TagIndexというモジュールを追加するやり方にした。
きっと、もっと「モダン」なやり方があるのだろうけど、とりあえずこれで対処。

• Done: タグ別アーカイブ
• Monthly, Daily アーカイブ
• コメント、トラックバック、RSS Ping。。。
  やっぱりオンライン系がいるなぁ

super_preとpreが同じ処理になっているので、(&")等を変換するように改変

Module::Installで作ったモジュールには通常incディレクトリとMANIFEST等が
入るが、svnで管理する場合にははずすことが多い。
Module::Installが利用できる環境でperl Makefile.PLすればよい。
その後、
make manifest
make dist
等する。

PathTools-3.2501を使う必要がある。

Version指定するときは、CPANのダウンロードリンクのid/以下を使う

my @result = grep{$_} @array;

tokuhiromさんのApp::Chariotという簡易ブログツールを入れた。


モダンなPerlということで、かなりすっきりしたソースでわかりやすい。
これから勉強。とりあえず、以下の変更をした。

-*pでプライベートとなるようにData::Clmemo::Itemを改変
-タイトルにPerlモジュール名(::)が入っても処理できるようにData::Clmemo::Itemを改変

Index: Item.pm
===================================================================
--- Item.pm	(revision 13612) 
+++ Item.pm	(working copy)
@@ -8,7 +8,7 @@
sub parse {
  my ($class, @lines) = @_; 
  
  -    my ($title, $tag, $body) = (shift @lines) =~ /\*(.*?)(\[.*\])?:(.*)/;
  +    my ($title, $tag, $body) = (shift @lines) =~ /\*([^p][^[]*)(\[.*\])?:(.*)/;
  return unless $title;
  
  $title =~ s/(^\s*|\s*$)//g;

perldoc perldelta
で読む。

解説希望。　よくわかりません。
複数パッケージを含む以下のようなperlスクリプトで(&)プロトタイプ宣言した関数を実行すると、動きません。(Can’t call method ‘fuga’ without a package or object….)

package hoge;
use base 'Exporter';
our @EXPORT = qw/ fuga foo/; 

sub fuga(&){ print $_[0]->();}
sub foo(){ print $_[0];}
1; 
package main;
import hoge;
# 駄目パターン
fuga {'fuga'};
#プロトタイプ宣言(&)してないやつはOK
foo('foo');
#関数として渡すとOK
fuga(sub{'fuga'});

プロトタイプで’&’を指定した場合、subをつけない無名関数(ブロック)を渡せるはずですが、渡せません。
で、package hogeを別ファイルに置くと、動きます。

use 'hoge' 
fuga {'fuga'}; #OK

なんか変だなぁ。
importとuseは違うのかなぁ？
なんか間違ってる？

• strawberry-perl-5.10.0.1-1がリリースされてた。
• VistaはXSモジュールがインストールできないらしい。

Vista対応されたらVaio に入れる。