ハッシュの値へのリファレンスを取得しました

my $hash_ref = { hogehoge => 1 };
my $scalar_ref = ¥($hash_ref->{hogehoge});
$hash_ref->{hogehoge} = 2;
print $$scalar_ref, "¥n";

初めは取れるのか？と思ってたのだが、意外とあっさり。

本当は、、

my $object = Class->new;
my $scalar_ref = ¥($object->hogehoge);
$object->hogehoge(2);
print $$scalar_ref, "¥n";

みたいに、アクセサーから取得したかったのだけど、どうやら、returnの時に値のコピーが発生しているようで、取得できなかった。。。

まぁ、なんで、こんな事がやりたかったかと言うと、DB上にファイルを保存する事になって、そのファイルの内容を取り出す関係で、極力、変数のコピーは避けたかったので、、、という説明じゃわからないね。まぁ、そんな感じの時に必要だったのよ。

簡単に説明すれば、DBIx::Class::InflateColumn::Fileしたかったの。

IO::Fileに、変数の参照渡して、スカラー変数をファイルみたいに、open したかった。

Net::FTP::Simple

ダウンロードされるファイルは実行パスみたい、、指定はできない模様、、。。
まぁちょっと使う程度にはいいかも。

my @received_filtered_files = Net::FTP::Simple->retrieve_files({
    username    => $username,
    password    => $password,
    server      => $server,
    remote_dir  => $remote_dir,
    debug_ftp   => 1,
    file_filter => qr/^2007/,
    mode        => 'ascii',
});

debug_ftp は、以下のような感じで出る。

Net::FTP=GLOB(0x300214d4)<<< 226 Transfer complete.
Net::FTP=GLOB(0x300214d4)>>> PORT 192,168,1,2,161,249
Net::FTP=GLOB(0x300214d4)<<< 200 PORT command successful
Net::FTP=GLOB(0x300214d4)>>> RETR 20070316.txt
Net::FTP=GLOB(0x300214d4)<<< 150 Opening ASCII mode data connection for 20070316.txt (35435 bytes)
Net::FTP=GLOB(0x300214d4)<<< 226 Transfer complete.
Net::FTP=GLOB(0x300214d4)>>> PORT 192,168,1,2,161,250
Net::FTP=GLOB(0x300214d4)<<< 200 PORT command successful
Net::FTP=GLOB(0x300214d4)>>> RETR 20070317.txt
Net::FTP=GLOB(0x300214d4)<<< 150 Opening ASCII mode data connection for 20070317.txt (114635226 bytes)

それにしても、インストールの時の依存モジュールの数ったら、結構、すごいね、、、（ｗ；

Deep recursion on subroutine ...

Class::Accessor を 間違えて use base せずに、単純に use したら、"Deep recursion on subroutine..." とか言われて少しハマッタ。。。

初めてのパッチを書いた

今さら、CGI::Application かよってのは置いておいて、、
CGI::Application::Plugin::Config::YAML を使うときに、いきなり、config_read を使うと、"No config file specified!" とか言われて怒られるのだが、、config_read に、ファイル名渡してるんだから、それ使ってよ。って事で、パッチ書いてみました、、
※初めてのパッチ作成
参考：diffとpatchについて

*** YAML.pm.org Fri Oct 28 16:49:42 2005
--- YAML.pm     Fri Jul  6 19:09:51 2007
***************
*** 78,93 ****

  sub config_read {
      my ($self, $file) = @_;
!     my $conf = $self->config();
      $conf->read($file);
      return;
  }

  sub config {
!     my $self = shift;
      my $create = !$self->{__CONFIG_YAML}->{__CONFIG_OBJ} || $self->{__CONFIG_YAML}->{__FILE_CHANGED};
      if ( $create ) {
!         my $file_name = $self->config_file or die "No config file specified!";

          my $conf;
          eval{
--- 78,93 ----

  sub config_read {
      my ($self, $file) = @_;
!     my $conf = $self->config($file);
      $conf->read($file);
      return;
  }

  sub config {
!     my ($self, $file) = @_;
      my $create = !$self->{__CONFIG_YAML}->{__CONFIG_OBJ} || $self->{__CONFIG_YAML}->{__FILE_CHANGED};
      if ( $create ) {
!         my $file_name = $self->config_file($file) or die "No config file specified!";

          my $conf;
          eval{

如何でしょう？？
作者様に送るかどうか、、、どうしよう、、とりあえず、送ってみようかな、、id:nekokak さんが作ったものなので、日本語でお願いできるし、、orz

YAML と YAML::Syck の違い

いろいろと、YAML 周りを試行錯誤していて、YAML と YAML::Syck の違いを見つけたので、ご報告。。。

my $my_yaml = <<'__YAML__';
---
  param1 : [ NOT_BLANK, ASCII, [ LENGTH, 2, 5 ] ]
  ? date: [ year, month, day ]
  : [ DATE ]

__YAML__

use YAML;
use YAML::Syck;
use Data::Dumper;

my $data1 = YAML::Load($my_yaml);
my $data2 = YAML::Syck::Load($my_yaml);

print "--data1--\n", Dumper($data1);
print "--data2--\n", Dumper($data2);

上記のコードは、先日、苦労して見つけた、? と : の記法を用いて、ハッシュのキーに、ハッシュを持たせるための方法ですが、実はこの記法は、YAML では対応しているが、、YAML::Syck では、対応していないという事が発覚した！！上記のコードの実行結果は以下のようになった

--data1--
$VAR1 = {
          'date: [ year, month, day ]' => [
                                            'DATE'
                                          ],
          'param1' => [
                        'NOT_BLANK',
                        'ASCII',
                        [
                          'LENGTH',
                          '2',
                          '5'
                        ]
                      ]
        };
--data2--
$VAR1 = {
          'HASH(0x8150b44)' => [
                                 'DATE'
                               ],
          'param1' => [
                        'NOT_BLANK',
                        'ASCII',
                        [
                          'LENGTH',
                          '2',
                          '5'
                        ]
                      ]
        };

Ingy++ !!
ちなみに、Dump も試してみたところ、、、

use YAML;
use YAML::Syck;

my $data = {
    param1 => ['NOT_BLANK', 'ASCII', ['LENGTH', 2, 5]],
    { date  => ['year',  'month', 'day'] } => ['DATE'],
};
print "--YAML::Dump--\n", YAML::Dump($data);
print "--YAML::Syck::Dump--\n", YAML::Syck::Dump($data);

実行結果、、、

--YAML::Dump--
---
HASH(0x815ebe4):
  - DATE
param1:
  - NOT_BLANK
  - ASCII
  -
    - LENGTH
    - 2
    - 5
--YAML::Syck::Dump--
---
HASH(0x815ebe4):
  - DATE
param1:
  - NOT_BLANK
  - ASCII
  -
    - LENGTH
    - 2
    - 5

って、どちらも、、ちゃんと Dump できないようでした、、、何か方法は無いのかなぁ、、(T_T)

追記：ハッシュになってるかと思いきや、、ただの文字列だった事に気づきました、、、このエントリーを見て、ハマッてしまった方、、大変、申し訳ありませんでした。。。m(__)m

YAML 1.0

FormValidator::Simple::ProfileManager::YAML に読み込ませるため、profile.yml を書いていて、Validator で、DATE チェックをさせる時、On Coding なら以下のように書くのだが、、YAML で書く場合に、どう書いたらいいのか分からず、、ずっと試行錯誤を繰り返し、、２、３時間ハマって、やっと出来たので、忘れないように残しておく。
On Coding の場合

use FormValidator::Simple;

my $result = FormValidator::Simple->check( $query => [
    param1 => ['NOT_BLANK', 'ASCII', ['LENGTH', 2, 5]],
    { date  => ['year',  'month', 'day'] } => ['DATE'],
]);

っと書けばいいのだが、これを YAML で、しかも、ハッシュの状態のまま持たせるには、どうしたらいいのか！？ちなみに、普通はリストで以下のように書く

---
  - param1
  - [ NOT_BLANK, ASCII, [ LENGTH, 2, 5 ] ]
  - date: [ year, month, day ]
  - [ DATE ]

っんで、これをハッシュと同じように持たせるには、以下のようにしたら上手くいった

---
  param1 : [ NOT_BLANK, ASCII, [ LENGTH, 2, 5 ] ]
  ? date: [ year, month, day ]
  : [ DATE ]

ちなみに、この特殊な書き方をすると、Alias が付けられなかった、、(ただの文字列扱いにされた)
参考：YAML Ain't Markup Language (YAML™) 1.0

っで、最悪な事に、このエントリーを書いていて、それって、自分が作りたい DataObject を、Perl で書いてから、それを、YAML::Dumper で、吐き出せばいいんじゃねっとか思った。。。orz -> 自爆メソッド

ちゃんと YAML を習得しなくてわ、、、

追記：上手くいってませんでした、、、申し訳ないです、、、ただの文字列として判定されていました、、。申し訳ないです。。。m(___)m

CGI::Application::Plugin::FormValidator::Simple::ProfileManager::YAML

を作ってみたｗ ってか、パッケージ名、長すぎっ(--;)
CPAN Author になりたいけど、これが、最初のモジュールってのも、なんか自分的に嫌だなぁ、、、。

package CGI::Application::Plugin::FormValidator::Simple::ProfileManager::YAML;

use strict;
use vars qw($VERSION @EXPORT);
use warnings;
use FormValidator::Simple::ProfileManager::YAML;

require Exporter;

@EXPORT = qw(
  set_profiler
  get_validate_profile
);
sub import { goto &Exporter::import }

$VERSION = '0.03';

sub set_profiler {
    my $self = shift;
    my ($path_to_profile) = @_;

    if (!$self->{validate_profiler}) {
        $self->{validate_profiler}
            = FormValidator::Simple::ProfileManager::YAML->new(
                $path_to_profile
            );
    }
    return $self->{validate_profiler};
}


sub get_validate_profile {
    my $self = shift;
    return
          $self->{validate_profiler}
        ? $self->{validate_profiler}->get_profile(@_)
        : {};
}


1;
__END__

使い方としては、以下のような感じです

package MyApp;

use strict;
use warnings;

use base 'CGI::Application';

use CGI::Application::Plugin::FormValidator::Simple::ProfileManager::YAML;

sub cgiapp_init {
    my $self = shift;

    $self->set_profiler($path_to_profile);
}

sub mode1 {
    my $self = shift;

    my $profile = $self->get_validate_profile('group1');

    $self->form(@$profile);

    # ～云々～
}

んー、いろいろ抜けてますが、とりあえずこれでいかがでしょうか？

■追記
タイトルが長すぎて、途中で切れてるっ

CGI - Perl から、Excel の出力

また、いつか使う時が来ると思うので、備忘録的に残しておこう、、サンプルコード。
どこかで、調べてコピッただけ、だけど、、、orz

use Jcode;
use Spreadsheet::WriteExcel::Big;
use Unicode::String qw(utf8 utf16);

print 'Content-type: application/vnd.ms-excel', "\n",
      'Content-Disposition: attachment; filename="結果.xls"', "\n\n";

my $workbook  = Spreadsheet::WriteExcel::Big->new("-");
my $worksheet = $workbook->add_worksheet;
my $format    = $workbook->addformat(font => "MS PGothic");

my ($row_num, $col_num) = (0,0);
for my $row (@rows) {
    for my $col (@$row) {
        $worksheet->write_unicode(
            $row_num, $col_num++,
            utf8(Jcode->new($col)->utf8)->utf16, $format,
        );
    }
    $row_num++;
}
$workbook->close;

注意点としては、、
Spreadsheet::WriteExcel::Big を使う事で、大量データのエクセルを作成できる、Big じゃないものだと、途中で落ちる、、？？とか、あったような、、
あと、utf16 じゃないと文字化けする？？
とか、こんな感じで Excel 作れたよって話し。。。
最新のモジュールとか見直してみた方がいいかも、、、。

sleep は、SIGALRM で解除できる。

最近、daemontools を利用した、perl プログラムを、以下のように書いている

my $END_FLG = 0;
$SIG{HUP} = $SIG{TERM} = sub {
    $END_FLG = 1;
};

while (sleep 60) {
    # ... bla bla bla ...
    exit if $END_FLG;
}

っで、SIGHUP とか SIGTERM とかが来たら、安全な場所で、プログラム停止ができるように組み込んだ、あと、調べて分かった事が、ひとつふたつあるので紹介。SIGKILL は、捕捉したり無視したりできないという事がわかった、それと、SIGSTOP も同じという事が発覚した、、。
参考:perlドキュメント日本語訳 - Perlのプロセス間通信#Signals
そこで、SIGSTOP が捕捉できないって事は、例えば、他サーバーと通信中に SIGSTOP とか受信したら、どうなるんだ？？通信相手には、STOP なんて知らせて無いのに強制停止、この時、返答が来たらどうなるの？？それに、通信中に停止すると、何も通信が無くなるから途中で、コネクションが強制切断されたりする可能性があるし、かなり困るなぁ、、、SIGSTOP が捕捉できないというのは、仕様としてどうなのだろう、、、？？

それと、タイトルの件だけど、sleep が SIGALRM で再開できるってのは、師匠の話によると、alarm を使って、sleep が実装されているとの事、なるほどぉ～！

っで、ふと思ったのだけど、上記に書いた実装方法だと、おそらくだけど、sleep に入って、1秒経過する前に SIGALRM を受信してしまうと、ループから抜けてしまう気がする、、。。

CPAN に登録されている全てのモジュールのリスト

を取得するスクリプトを作ったので晒してみる。。。

#!/usr/bin/env perl

use strict;
use warnings;
use LWP::Simple;

my $url     = 'http://www.cpan.org/modules/02packages.details.txt';
my $content = get($url) or die $@;

open my $fh, '> cpan_modules.txt' or die $!;
for (
    split /(?:\r\n|\r|\n)/, (split /(?:\r\n|\r|\n){2}/, $content)[1]
) {
    print $fh (split /\s+/, $_)[0], "\n";
}
close $fh;

ってか、勝手に "http://www.cpan.org/modules/02packages.details.txt" この URL を使わせてもらってるのだが、いいのか？
エラー処理とか改行コードとか、かなり適当な感じなのだが、、まっ、取得できたしいいかw

AAA::Demo
AAC::Pvoice
AAC::Pvoice::Bitmap
AAC::Pvoice::Dialog
AAC::Pvoice::EditableRow
AAC::Pvoice::Input
AAC::Pvoice::Panel
...
...
...

動かすと、↑こんなのが取得できる。

Text::CSV は日本語入ってるとダメなんだ、、、orz

Text::CSV で parse したらエラー出まくりだったので、エラーになってる CSVのファイルをのぞくと日本語の行がエラーになっていた、、、orz どうやら、日本語入っているとダメみたい、、っで、検索してみたら「勝手に添削 - PerlによるCSVファイルの高速集計 2 - 404 Blog Not Found」で、Text::CSV_XS で、{binary=>1} のオプションを付けると、どうやら日本語混じりでも OK らしいので、さっそくインストールしてコードを修正。モジュール名の変更だけで済んだ。

use strict;
use warnings;
use Text::CSV_XS;

$| = 1;

my $file = './hoge.csv';

my $csv = Text::CSV_XS->new({binary=>1});

open my $fh, '<', $file or die $!;
while (<$fh>) {
    chomp;
    $csv->parse($_) or next;

    my @fields = $csv->fields;

    # ... your code here ...
}
close $fh;

ちなみに環境

C:\>perl -v

This is perl, v5.8.8 built for MSWin32-x86-multi-thread
(with 50 registered patches, see perl -V for more detail)

Copyright 1987-2006, Larry Wall

Binary build 820 [274739] provided by ActiveState http://www.ActiveState.com
Built Jan 23 2007 15:57:46

Perl may be copied only under the terms of either the Artistic License or the
GNU General Public License, which may be found in the Perl 5 source kit.

Complete documentation for Perl, including FAQ lists, should be found on
this system using "man perl" or "perldoc perl".  If you have access to the
Internet, point your browser at http://www.perl.org/, the Perl Home Page.

Regexp::Assemble 便利っぽい

にぽたん研究所 - 二度目の公開！電話番号の正規表現 で、紹介されてた Regexp::Assemble がとっても便利そうなのでメモメモ。

  use Regexp::Assemble;
  
  my $re = Regexp::Assemble->new;
  $re->chomp(1);
  $re->add(<DATA>);
  print $re->re;

__DATA__
104
103
102

ってな感じで、正規表現としてマッチさせたいデータを流し込むと、解析してマッチさせるための正規表現を作ってくれちゃう、便利そうなモジュール。

Google - Regexp::Assemble
ってか、ずいぶん前から紹介されてたんだね、、、orz
今度、機会があったら試してみよう。