戯術者の日記

Visual SourceSafe アドミニストレータ を起動し、[アーカイブ(A)]->[プロジェクトのアーカイブ(A)]で、バージョン範囲を[全てのデータを保存(A)]で Go

ぺるりめも - ハンドル名を変数に入れる の方法では、undef のスカラ変数を open の引数にしても

Can't use an undefined value as filehandle reference at ./test.pl line 11.
Can't use an undefined value as a symbol reference at ./test.pl line 11.    (use strict時)

で、実行できない。

で、version 5.005_03 built for sun4-solaris で試した結果、

my $fh = "";

と、とりあえず空文字にしておけばクリアできた…
いいのかな。

で、これだと気持ち悪いので、FileHandle モジュールを使う方法。

use FileHandle;

my $fh;
$fh = new FileHandle "sample.txt", "r"
  or die "cannot open: $!\n";
while (<$fh>) {
  print;
}
$fh->close;

書式が C 言語っぽい…

コード

sub print_a_list(\@\@) {
  my $list1 = shift;
  my $list2 = shift;
  foreach my $a (@$list1) {
    print "$a\n";
  }
}

@array1 = (1,2,3);
@array2 = (4,5,6);
print_a_list(@array1, @array2);

結果

% ./test.pl
1
2
3

プロトタイプとして \@ を指定することで、配列のリファレンスとして受け取ることを強制できる。
サブルーチン内では結局配列のリファレンスをいじるハメになるけど、呼び出し側は引数を配列のまま渡すことができる。

MUA(メーラ)や telnet じゃちょっと無理だけど、プログラム書いちゃえば簡単。
Net::SMTP, Mail::Sender, Mail::Sendmail の3つを試したが、どれも送信可能。RFC的にはコントロールコードを含むascii文字を送信して良いと読めるので、MTAは処理しなければならない…と思う。少なくとも、MTA が core 吐いて死んだりとかは NG でしょう。

RFC2821 4.5.2 Transparency より引用

   The mail data may contain any of the 128 ASCII characters. All
   characters are to be delivered to the recipient's mailbox, including
   spaces, vertical and horizontal tabs, and other control characters.

Net::SMTP版

use Net::SMTP;
$smtp = Net::SMTP->new("localhost",
                       Debug => 1) or die;
$smtp->mail('from@mail.example.org');
$smtp->to('to@mail.example.org');
$smtp->data();
$smtp->datasend("\x1\x0\x1");
$smtp->dataend();
$smtp->quit();

Mail::Sender版

use Mail::Sender;
$sender = new Mail::Sender{smtp => 'localhost',
                           from => 'from@mail.example.org'};
$sender->MailMsg({ to => 'to@mail.example.org',
                   msg => "\x1\x0\x1" });

Mail::Sendmail版

use Mail::Sendmail;
$Mail::Sendmail::mailcfg{mime} = 0;
sendmail( To => 'to@mail.example.org',
          From => 'from@mail.example.org',
          Message => "\x1\x0\x1" ) or die $Mail::Sendmail::error;

Mail::Sender は、デフォルトでは(MIME::QuotedPrintが使えれば)quoted-print エンコードして送信するので、mailcfg{mime} を false に設定する。

少なくとも子プロセスの pid はわかってるはずだから、プロセスグループ ID を取得して、kill する。

$pgrp = getpgrp $chld_pid;
kill -9, $pgrp;

kill の第一引数は、送りたいシグナル番号。

かなりドンくさいけどテストコード

if ($pid[0] = fork) {
  # oya;
  local $SIG{INT} = sub {
    my $pgrp = getpgrp $pid[0];
    print "pgrp: ", $pgrp, "\n";
    print "catch ", shift, " (oya)\n";
    kill -15, $pgrp;
    exit;
  };
  &loop;
}
elsif (defined $pid[0]) {

  if ($pid[1] = fork) {
    # ko
    local $SIG{TERM} = $SIG{HUP} = sub {
      print "catch ", shift, " (ko)\n";
      exit;
    };
    &loop;
  }
  elsif (defined $pid[1]) {

    local $SIG{CHLD} = 'IGNORE';

    if ($pid[2] = fork) {
      # mago
      local $SIG{TERM} = $SIG{HUP} = sub {
        print "catch ", shift, " (mago)\n";
        exit;
      };
      &loop;
    }
    elsif (defined $pid[2]) {
      # himago
      local $SIG{TERM} = $SIG{HUP} = sub {
        print "catch ", shift, " (himago)\n";
        exit;
        };
      &loop;
    }
  }
}

sub loop {
  while (1) {
    print "sleep ";
    sleep 1;
  }
}

kill にシグナル名を与えられないのは微妙に使いにくいかな??

実行

% ./test.pl
sleep sleep sleep sleep ^Cpgrp: 7060
catch INT (oya)
catch TERM (himago)
catch TERM (mago)
catch TERM (ko)
zsh: terminated  ./test.pl

というわけで試作。Perl 5.8+ 用。shift_jis -> eucjp 固定

#!/usr/bin/perl

use Encode qw(from_to);
use File::Find;

my $basedir = shift;
-d $basedir or die "Usage $0 dir\n";

find( sub {
        my $target = $_;
        sj2e($target) if -f $target;
      },
      $basedir);

find( sub {
        my $target = $_;
        sj2e($target) if -d $target;
      },
      $basedir);

sub sj2e {
  my $from = shift;
  my $to = $from;
  from_to($to, "shiftjis", "euc-jp");
  rename($from, $to) ? print "renamed: ", $File::Find::name, "\n" :
    print "renamed failed: ", $File::Find::name, "\n";
}

なんか、ムダに長いなぁ。ってか、1パスで動作させた方がスマートかも。
ascii のみのファイル/ディレクトリの場合は、同じファイル名への rename のため失敗するが、仕様です :p

#!/usr/bin/perl

use POSIX;

my $fmt = shift;
if ($fmt =~ m#(\d{4})/(\d{2})/(\d{2})-(\d{2}):(\d{2}):(\d{2})#) {
  print strftime "%a, %d-%b-%Y %H:%M:%S\n", $6, $5, $4, $3, $2 - 1, $1 - 1900;
}
elsif (not defined $fmt) {
  print strftime "%a, %d-%b-%Y %H:%M:%S\n", localtime;
}
else {
  print "Invalid format\n";
  print "$0 YYYY/mm/dd-HH:MM:ss\n";
}

実行

$ cookiefmt 2005/08/10-16:17:11
Wed, 10-Aug-2005 16:17:11

だからナニ? って感じだけど^^;

hmiyazaki@chaource:~/work/prog/win/practice$ bcc base.c 
Borland C++ 5.5.1 for Win32 Copyright (c) 1993, 2000 Borland
base.c:
警告 W8057 base.c 31: パラメータ 'hPrevInst' は一度も使用されない(関数 WinMain )
警告 W8057 base.c 31: パラメータ 'lpsCmdLine' は一度も使用されない(関数 WinMain )
Turbo Incremental Link 5.00 Copyright (c) 1997, 2000 Borland
Error: 外部シンボル '_main' が未解決（C:\BORLAND\BCC55\LIB\C0X32.OBJ が参照）

これは -W オプションを付けてコンパイルする。

hmiyazaki@chaource:~/work/prog/win/practice$ bcc -W base.c 
Borland C++ 5.5.1 for Win32 Copyright (c) 1993, 2000 Borland
base.c:
警告 W8057 base.c 31: パラメータ 'hPrevInst' は一度も使用されない(関数 WinMain )
警告 W8057 base.c 31: パラメータ 'lpsCmdLine' は一度も使用されない(関数 WinMain )
Turbo Incremental Link 5.00 Copyright (c) 1997, 2000 Borland

VisualStudio買おうかな。いや、でも、うーん…

Pkg::method($arg1, $arg2);

とすれば、sub method での $_[0] は $arg1, $_[1] は $arg2

Pkg->methoc($arg1, $arg2);

とすれば、sub method での $_[0] は "Pkg", $_[1] は $arg1, $_[2] は $arg2 になる。

OOP 形式のコードじゃない場合は、前者で実行するか EXPORT しておくのが無難

買った。会社がヒマなんで、これでしばらく遊んでみよう。

m/[ -~]/

0x20(スペース)から0x7e(チルダ)まで。
0x20未満のハードタブ(0x09)や改行(0x0A)は個別に対処せよ。
0x7F(DEL)はいらねーよな。

あぁ、grep でも使える

$ command | grep -v '[ -~]'

asciiを含まない行を出力

$ command | grep '[^ -~]'

ascii以外を含む行を出力

lv(v.4.50, v.4.51)の正規表現検索は、スペースを範囲に含めると overcrossing range と出力されて効かないので、0x21の!から指定する

/[^ !-~]

ascii以外(タブなど除く)を含む行を出力

less(351, 358)は [ -~]で大丈夫なんだけどなぁ。意外にも more も大丈夫だ。

[2005-06-14-2]でカテゴリ名を RSS フィードに表示するようにしたけど、カテゴリの数が多いと(こんな使い方余りいない??)、Firefox のライブブックマークでの非表示部分が多くなってしまう。
ので、記述しているカテゴリ名のうち、最後の1個だけを表示するように修正

前回の状態からは

--- chalow.20050706     2005-06-29 19:40:01.000000000 +0900
+++ chalow      2005-07-06 17:55:49.000000000 +0900
@@ -1102,7 +1102,7 @@

            push @items, {
                permlink => $permlink,
-               itemheader => html2xmlstr("[".join("][", @{$all_entries{$ymd}{$i}{cat}})."]".$all_entries{$ymd}{$i}{h}),
+               itemheader => html2xmlstr("[" . $all_entries{$ymd}{$i}{cat}[$#{$all_entries{$ymd}{$i}{cat}}] . "]" . $all_entries{$ymd}{$i}{h}),
                itemauthor => $all_entries{$ymd}{$i}{a},
                itemcontent => $cont,
                itemcontentencoded => $coen,

てな感じで。

スゲー見にくいけど、要は

$array[$#array]

で、配列最後の要素をとってるだけ。
先頭がよければ、0 で良い(未確認)

ま、これは簡単か

--- chalow.20050030     Fri Jun 24 23:51:11 2005
+++ chalow      Thu Jun 30 00:04:47 2005
@@ -1185,7 +1185,7 @@
     return if ($output_cat_pages == 0 and $cat_page_cgi eq "");

     my @lines = ();
-    foreach my $cat (sort keys %category_count) {
+    foreach my $cat (sort { lc $a cmp lc $b } keys %category_count) {
        my $n = $category_count{$cat};
 #    foreach my $cat (sort keys %category_item) {
 #      my $n = scalar(@{$category_item{$cat}});

久々に呪文(?)作成

my %count = ();
foreach (map {$_->[1]} sort {$a->[0] <=> $b->[0]} grep { $count{$_->[0]} > 1 } grep { ++$count{$_->[0]} } map { [$hash{$_}, $_] } keys %hash) {
  printf "%s\t%d\n", $_, $hash{$_};
}

もっと短くならないものだろうか… ^^;

メールを送るのに便利な Mail::Sender だけど、ポートの指定ができない(25/tcp固定)ので、オブジェクトの作成時にポート指定できるようにするパッチ。

--- Sender.pm.org       2005-06-27 10:43:24.000000000 +0900
+++ Sender.pm   2005-06-27 10:43:24.000000000 +0900
@@ -811,7 +811,6 @@
        delete $self->{'_buffer'};
        $self->{'debug'} = 0;
        $self->{'proto'} = (getprotobyname('tcp'))[2];
-       $self->{'port'} = getservbyname('smtp', 'tcp')||25 if not defined $self->{'port'};
 
        $self->{'boundary'} = 'Message-Boundary-by-Mail-Sender-'.time();
        $self->{'multipart'} = 'mixed'; # default is multipart/mixed
@@ -838,6 +837,8 @@
                }
        }
 
+       $self->{'port'} = getservbyname('smtp', 'tcp')||25 if not defined $self->{'port'};
+
        $self->{'fromaddr'} = $self->{'from'};
        $self->{'replyaddr'} = $self->{'reply'};

まぁ、単純に、$self->{'port'} のセット位置を変更するだけなんだけど。

@array = map { "foobar" } (1..1000);

他にいい方法ないかな…

[2005-06-13-2]の続き。
sub write_rss_file の itemheader にタイトル名を突っ込む箇所に、同じように、カテゴリ名も含ませる

--- chalow.org     2005-06-13 18:00:26.000000000 +0900
+++ chalow      2005-06-14 12:55:53.000000000 +0900
@@ -1102,7 +1102,7 @@

            push @items, {
                permlink => $permlink,
-               itemheader => html2xmlstr($all_entries{$ymd}{$i}{h}),
+               itemheader => html2xmlstr("[".join("][", @{$all_entries{$ymd}{$i}{cat}})."]".$all_entries{$ymd}{$i}{h}),
                itemauthor => $all_entries{$ymd}{$i}{a},
                itemcontent => $cont,
                itemcontentencoded => $coen,

って、まだ www.jp-z.jp のには反映してないんだけど。

sub write_latest_item_list_file の部分。
$all_entries{$ymd}{$i}{cat} に、カテゴリ文字列の入った配列のリファレンスがあるんで、これをくっつければいい。

foreach my $i (sort {$b <=> $a} keys %{$all_entries{$ymd}}) {
  next if ($i !~ /^\d/);
    my ($ym) = ($ymd =~ /^(\d{4}-\d\d)-\d\d/);
    my $c = $all_entries{$ymd}{$i}{h};
    $c =~ s/[\t\n]//g;
    $c =~ s/\s\s+/ /g;
    [...]
    $c = $c . "[" . join("][", @{$all_entries{$ymd}{$i}{cat}}) . "]";    # <= ココ

[2005-06-03-1] のやつ。
まず、CGI でファイルアップローダ(chlogup.cgi)をテキトーに作成

#!/usr/bin/perl
use CGI;
my $cgi = new CGI;
my $updata = $cgi->param('file');
my $chfile = "ChangeLog";

print $cgi->header('text/plain');

unless (open F, "> $chfile") {
  print "open error $chfile: $!\n";
  exit 1;
}
while (<$updata>) {
  print F;
}
close F;

print "exec chalow start\n";
print `/foo/bar/exec.sh 2>&1`;
print "exec chalow done\n";

で、ChangeLog をさくらへ up し、chalow を実行するシェルスクリプト(exec.sh)を作成

#!/bin/sh

/bin/cat ChangeLog | /usr/bin/ssh -i sshの鍵 username@sakura 'cat | env PERL5LIB=local/chalow/ local/chalow/chalow -c local/chalow/cl.conf -o www/changelog -'

CGI を呼ぶ HTML もテキトーに。

<html>
<body>
<form action="chlogup.cgi" method="post" enctype="multipart/form-data">
<input type="file" name="file">
<input type="submit">
</form>
</body>
</html>

さくらのサーバ上の ~/local/chalow 以下に chalow があるのが前提。

あとは、https でアクセスできるサーバにおいて、BASIC認証なりなんなりで制限すればいい(httpsなんでBASIC認証で十分でしょ)

pipe(READ, WRITE);
select((select(WRITE), $|=1)[0]);

if ($pid = fork) {
  close WRITE;
  while (<READ>) {
    print;
  }
  exit;
}
elsif (defined $pid) {
  print WRITE "foo\n";
  print WRITE "bar\n";
  print WRITE "baz\n";
  exit;
}

まぁ、単純化してこんな感じ
バッファのフラッシュはしておかないと、反応が鈍い。

…あれ? Perl はしばらく書かなかったんじゃ??＞自分