【しばらく編集不可モードで運営します】 編集(管理者用) | 差分 | 新規作成 | 一覧 | RSS | FrontPage | 検索 | 更新履歴

PerlToUlang - ソース

目次

ソース

#Perlのモジュールファイルから、U言語を生成する。
# $Id: PerlToUlang.pm,v 1.5 2003/05/03 04:09:03 coffee Exp $

# $Log: PerlToUlang.pm,v $
# Revision 1.5  2003/05/03 04:09:03  coffee
# use warnings;
#
# Revision 1.4  2003/05/03 04:06:07  coffee
# malti package module ok.
#
# Revision 1.3  2003/05/03 03:28:54  coffee
# add Revision tag for automatical $VERSION update.
#
# Revision 1.2  2003/05/03 03:25:44  coffee
# add Id tag and Log tag.
#

package PerlToUlang;

use 5.006;
use strict;
use warnings;
use IO::File;
use Data::Dumper;

require Exporter;

our @ISA = qw(Exporter);

# *** perl2ulang.pl ***
# use PerlToUlang qw(perl2ulang);
#
# foreach (perl2ulang(@ARGV)) {
#     print;
# };

our %EXPORT_TAGS = ( 'all' => [ qw(
    perl2ulang
) ] );
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT = qw();
our ($VERSION) = q($Revision: 1.5 $) =~ m/\x20([\d.]+)\x20/;

my $DEBUG = 0;

sub perl2ulang {
    my @perl_source_file_name = $#_ ? @_ : @ARGV;
    my @result_ulang = ();
    if (defined(wantarray)) {
        local undef $/;
        foreach my $file_name (@perl_source_file_name) {
            if (-e $file_name) {
            my @tree = ();
            my $tree = {};
            my $fh = IO::File->new("<$file_name");
            my $perl_source = <$fh>;
            while ($perl_source) {
                #print length($perl_source) . "\n";
                if (0) {
                } elsif ($perl_source =~
                     s/^((__(END|DATA)__\n)(.*\n)+)//) {
                    print "[[[END TAG]]]\n$1\n" if $DEBUG;
                } elsif ($perl_source =~
                     s/^((\n=(head1|head2|title|over|back|pod|for|begin|end))\s.*\n(.*\n)*?)=cut(?>\n)//) {
                    print "[[[POD]]]\n$1\n" if $DEBUG;
                } elsif ($perl_source =~
                     s/^(<<([A-Z]+)(.*\n)+?\2(?>\n))//) {
                    print "[[[HIRE_DOCUMENT]]]\n$1\n" if $DEBUG;
                } elsif ($perl_source =~
                     s/^((["'])(.*?)(?<!\\)\2)//) {
                    print "[[[STRING]]]\n$1\n" if $DEBUG;
                } elsif ($perl_source =~
                     s/^(\s+tr(\/|!|"|#|\$|%|&|\'|~|=|^|\|).*?(?<![\\])\2.*?(?<![\\])\2)//) {
                print "[[[TR]]]\n$1\n" if $DEBUG;
                } elsif ($perl_source =~
                     s/^(\s+s(\/|!|"|#|\$|%|&|\'|~|=|^|\|).*?(?<![\\])\2.*?(?<![\\])\2)//) {
                    print "[[[REGEXP S]]]\n$1\n" if $DEBUG;
                } elsif ($perl_source =~
                     s/^(\s+m?(\/|!|"|#|\$|%|&|\'|~|=|^|\|).*?(?<![\\])\2)//) {
                    print "[[[REGEXP M]]]\n$1\n" if $DEBUG;
                } elsif ($perl_source =~
                     s/^(\$#)//) {
                    print "[[[NOT COMMENT]]]\n$1\n" if $DEBUG;
                } elsif ($perl_source =~
                     s/^(#.*(?>\n))//) {
                    print "[[[COMMENT]]]\n$1\n" if $DEBUG;
                } elsif ($perl_source =~
                     s/^package\s+(((?:[A-Za-z_][A-Za-z_0-9]*::)*)([A-Za-z_][A-Za-z_0-9]*))//) {
                    print Dumper($tree) if $DEBUG;
                    push(@tree, $tree);
                    $tree = {};
                    $tree->{package_fullname} = $1;
                    $tree->{class} = $3;
                    $tree->{package_fullname} =~ m/^(.*)::/;
                    $tree->{package} = $1;
                    print "[[[PACKAGE]]]\n$1\n" if $DEBUG;
                } elsif ($perl_source =~
                     s/^(use\s+base\s+qw\s*\((.*)\))//) {
                    my @extends = split(/\s+/, $2);
                    foreach (@extends) {
                        #print "$_\n";
                        $tree->{extends}->{$_} = 1;
                    }
                    print "[[[EXTENDS]]]\n$1\n" if $DEBUG;
                } elsif ($perl_source =~
                     s/^(use\s+base\s+\((.*)\))//) {
                    my @extends = split(/["']?\s*,\s*["']?|["']/, $2);
                    foreach (@extends) {
                        #print "$_\n" if $_;
                        $tree->{extends}->{$_} = 1 if $_;
                    }
                    print "[[[EXTENDS]]]\n$1\n" if $DEBUG;
                } elsif ($perl_source =~
                     s/^sub\s+([A-Za-z_][A-Za-z_0-9]*)//) {
                    print "[[[METHOD]]]\n$1\n" if $DEBUG;
                    my $token_of_method = $1;
                    $token_of_method =~ m/^(_?)(.+)$/;
                    if ($1) {
                        $tree->{method}->{protected}->{$2} = 1;
                    } else {
                        $tree->{method}->{public}->{$2} = 1;
                    }
                } elsif ($perl_source =~
                     s/^\$(?:self|this)->{([a-zA-Z_]+?)}//) {
                    $tree->{field}->{$1} = 1;
                    print "[[[FIELD]]]\n$1\n" if $DEBUG;
                } else {
                    $perl_source =~ s/^(.|\s|\t|\n)//;
                    print "$1" if $DEBUG;
                }
            }
            print Dumper($tree) if $DEBUG;
            push(@tree, $tree);
            $fh->close();
            shift @tree;
            my $local_ulang = _tree2ulang(@tree);
            push(@result_ulang, $local_ulang);
            } else {
            print STDERR "$! $file_name\n";
            }
        }
    } else {
        print "コンテキストによって、自動的にファイルに書き出すようにしたいです。\n"
    }
    return @result_ulang;
}

sub _tree2ulang {
    my @tree = @_;
    my $local_ulang;
    foreach my $tree (@tree) {
    my $double_line = '=' x 20;
    my $single_line = '-' x 20;
    $local_ulang .= <<SOURCE;
**** $tree->{package} ****
$double_line
  $tree->{class}
$single_line
// field
SOURCE
    foreach (sort keys %{ $tree->{field} }) {
        $local_ulang .= "- $_\n";
    }
    $local_ulang .= <<SOURCE;
$single_line
// protected method
SOURCE
    foreach (sort keys %{ $tree->{method}->{protected} }) {
        $local_ulang .= "- $_\n";
    }
    $local_ulang .= <<SOURCE;
// public method
SOURCE
    foreach (sort keys %{ $tree->{method}->{public} }) {
        $local_ulang .= "+ $_\n";
    }
    $local_ulang .= <<SOURCE;
$double_line
// extends
SOURCE
    foreach (sort keys %{ $tree->{extends} }) {
        $local_ulang .= "$tree->{package_fullname} ----|> $_\n";
    }
    $local_ulang .= "\n";
    }
    return $local_ulang;
}
    
1;
__END__
=head1 NAME

PerlToUlang - Perlのモジュールファイルから、U言語を生成する。

=head1 SYNOPSIS

  use PerlToUlang qw(perl2ulang);
  my @u_language_source_code = perl2ulang(@perl_source_file_name);
  
=head1 DESCRIPTION

このモジュールは、奇怪な構文を極力控えて書かれた典型的なPerlモジュールに対して、
正しく動作します。(一般に配布されているPerlモジュールなら、ほとんど問題なく動作するはずです。)

現時点で、このモジュールは正当なU言語出力を生成することを狙ってはいません。
正当な出力を生成できない理由は、いくつかあります。

まずPerlには、言語仕様上の特性からUML及びU言語の表現に対応していない部分があります。
私はこれをUNIX文化上の美徳とされる、慣習という名のルールにもとづいて解決しようと試みました。
(たとえば、先頭にアンダースコアが付いたサブルーチン及びメソッドは、
 UMLのprivate属性に相当するものとして解釈され、「-」付きで出力されます。
 また、$selfをインスタンスを表す変数として使っていると仮定することで、
 クラスのフィールドを見つけようと試みています。)
しかし、昨今のWindowsの普及率を考えると、これがうまくいかないケースも多々あるでしょう :-)

次に、Perlの構文解析は辛い作業です。
Perlプログラム(あなたがスクリプターと呼ばれたいならPerlスクリプトと呼んでも可)のパース工程は
非常に複雑なものらしく、PerlFaqによれば完全なPerlパーサーはperl以外に存在しません。
そのため、JavaがDocletプログラムによって生成済のJavaのツリー構造にアクセスする場合のように、
簡単で確実でポータブルな方法は存在しないようなのです。ちぃっ!なんてこった! :-(

そこで発想を変えました。
Perlなのですから、簡単にやりたいことは簡単にやってしまえばいいのです。うあああ。
私はダークサイドに堕ちた後、いくつかの問題をあえて無視してロジックを書き上げました。

「出力の正当性?ああ、確かに持っていたとも。だが、残念!どこかに置き忘れてしまったらしい。」

利用したアルゴリズムは、文脈を検出して必要な情報を探すもので、これは改善の余地があるものです。
#×最悪の場合「一文字ずつ」の正規表現マッチが行われます。
#○大抵の場合「一文字ずつ」の正規表現マッチが行われます。

=head1 TODO

 * qw()を始め、いくつかの構文に対応していません。
 結果的に、その中に偶然「sub hoge{}」などと書いてあったりすると誤作動します。
 * コンテキストによって、結果を*.ulangファイルに自動的に書き出すようにしたいです。
 * 枠線を要素の長さ or 任意の長さに揃える機能が欲しいところ。
 最大長を超えたら強制的に折り返しする or しない、とか。

=head1 AUTHOR

 Coffee

=head1 LICENSE

 PerlToUlang : Perlのモジュールファイルから、U言語を生成する。
 Copyright (C) 2002-2003 Coffee (coffeex@lapis.plala.or.jp)
 Perlの配布条件に従います。

=cut

コメント

 [[#rcomment]]