CGI.pm の importメソッドの仕組みを見てみる

続・初めてのPerl p.202 を見て、 CGI.pm の import メソッドの仕組が気になったのでソースを読んでみることにする。

まずは、CGI.pm が置いてある場所を調べよう。
モジュールのパスを最初に調べて、

% perl -e 'print map "$_\n", @INC;'
/usr/lib/perl5/site_perl/5.8.8/i386-linux-thread-multi
/usr/lib/perl5/site_perl/5.8.7/i386-linux-thread-multi
/usr/lib/perl5/site_perl/5.8.6/i386-linux-thread-multi
/usr/lib/perl5/site_perl/5.8.5/i386-linux-thread-multi
/usr/lib/perl5/site_perl/5.8.8
/usr/lib/perl5/site_perl/5.8.7
/usr/lib/perl5/site_perl/5.8.6
/usr/lib/perl5/site_perl/5.8.5
/usr/lib/perl5/site_perl
/usr/lib/perl5/vendor_perl/5.8.8/i386-linux-thread-multi
/usr/lib/perl5/vendor_perl/5.8.7/i386-linux-thread-multi
/usr/lib/perl5/vendor_perl/5.8.6/i386-linux-thread-multi
/usr/lib/perl5/vendor_perl/5.8.5/i386-linux-thread-multi
/usr/lib/perl5/vendor_perl/5.8.8
/usr/lib/perl5/vendor_perl/5.8.7
/usr/lib/perl5/vendor_perl/5.8.6
/usr/lib/perl5/vendor_perl/5.8.5
/usr/lib/perl5/vendor_perl
/usr/lib/perl5/5.8.8/i386-linux-thread-multi
/usr/lib/perl5/5.8.8

次に、適当そうな深さのディレクトリで find してみる。おっ、あったあった。

% find /usr/lib/perl5/ -name CGI.pm
/usr/lib/perl5/5.8.8/CGI.pm

今日は遅いので寝る。つづきは、明日書くかもしれないし書かないかもしれない。というより、ソース読んでも理解できない可能性が大。もし、全く理解できなかったら、エントリは消さないで読める日が来ることを待つことにしとく。

なんとなくしか分からなかったけど、分かったところまでメモしておくことにした。

基本的に、CGI.pm の import のやっていることを要約すると以下のようになる。（続・初めてのPerl p.204）

sub import {
  # (1) シンボリックリファレンスを許可する。ラクダ本 p.304, p.1019
  no strict 'refs';
  # (2) インポートリストに debug が含まれていたら $debug を真にする
  my $debug = grep { $_ eq 'debug' } @_;
  # (3) 呼び出し元のパッケージ名を取得する
  my ($package, $file, $line) = caller;
  warn "I was called by $package in $file\n" if $debug;
  # (4) 現在のパッケージを呼び出し元パッケージにエクスポートする
  for (qw(filename basename fileparse)) {
    # 型グロブに代入することによって、現在のパッケージの内容を呼び出し元パッケージにエクスポートする（エイリアス処理）
    # ラクダ本 p.341
    *{$package . "::$_"} = \&$_;
  }
}

実際の、CGI.pm 中の importの抜粋。番号は上に示した単純な例との対応関係を表す。

# to import symbols into caller
sub import {
    # use strict を使ってないので、(1)の工程は必要無い。
    my $self = shift;

    # This causes modules to clash.
    undef %EXPORT_OK;
    undef %EXPORT;

    # (2) インポートリストに応じてフラグを立てる
    $self->_setup_symbols(@_);
    # (3) 呼び出し元のパッケージ名を取得する
    my ($callpack, $callfile, $callline) = caller;

    # To allow overriding, search through the packages
    # Till we find one in which the correct subroutine is defined.
    # (4) 現在のパッケージを呼び出し元パッケージにエクスポートする
    #     親にエクスポートしたい内容があるかもしれないので、親も検索対象にする
    my @packages = ($self,@{"$self\:\:ISA"});
    foreach $sym (keys %EXPORT) {
        my $pck;
        my $def = ${"$self\:\:AutoloadClass"} || $DefaultClass;
        foreach $pck (@packages) {
            if (defined(&{"$pck\:\:$sym"})) {
                $def = $pck;
                last;
            }
        }
        *{"${callpack}::$sym"} = \&{"$def\:\:$sym"};
    }
}

sub _setup_symbols {
  my $self = shift;
  my $compile = 0;

  # to avoid reexporting unwanted variables
  undef %EXPORT;

  foreach (@_) {
        $HEADERS_ONCE++,         next if /^[:-]unique_headers$/;
        $NPH++,                  next if /^[:-]nph$/;
        $NOSTICKY++,             next if /^[:-]nosticky$/;
        $DEBUG=0,                next if /^[:-]no_?[Dd]ebug$/;
        $DEBUG=2,                next if /^[:-][Dd]ebug$/;
        $USE_PARAM_SEMICOLONS++, next if /^[:-]newstyle_urls$/;
        $XHTML++,                next if /^[:-]xhtml$/;
        $XHTML=0,                next if /^[:-]no_?xhtml$/;
        $USE_PARAM_SEMICOLONS=0, next if /^[:-]oldstyle_urls$/;
        $PRIVATE_TEMPFILES++,    next if /^[:-]private_tempfiles$/;
        $TABINDEX++,             next if /^[:-]tabindex$/;
        $CLOSE_UPLOAD_FILES++,   next if /^[:-]close_upload_files$/;
        $EXPORT{$_}++,           next if /^[:-]any$/;
        $compile++,              next if /^[:-]compile$/;
        $NO_UNDEF_PARAMS++,      next if /^[:-]no_undef_params$/;

        # This is probably extremely evil code -- to be deleted some day.
        if (/^[-]autoload$/) {
            my($pkg) = caller(1);
            *{"$ {pkg}::AUTOLOAD"} = sub {
                my($routine) = $AUTOLOAD;
                $routine =~ s/^.*::/CGI::/;
                &$routine;
            };
            next;
        }

            foreach (&expand_tags($_)) {
            tr/a-zA-Z0-9_//cd;  # don't allow weird function names
            $EXPORT{$_}++;
        }
    }
    _compile_all(keys %EXPORT) if $compile;
    @SAVED_SYMBOLS = @_;
}

また後で書き足していくかもしれない。