manakai/bin/dis2pm.pl

#!/usr/bin/perl -w 
use strict;
use Message::Util::QName::Filter {
  d => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/lang#dis-->,
  dis2pm => q<http://suika.fam.cx/~wakaba/archive/2004/11/8/dis2pm#>,
  DOMCore => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/dom-core#>,
  DOMMain => q<http://suika.fam.cx/~wakaba/archive/2004/dom/main#>,
  lang => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/lang#>,
  Perl => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/lang#Perl-->,
  license => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/license#>,
  ManakaiDOM => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/manakai-dom#>,
  owl => q<http://www.w3.org/2002/07/owl#>,
  rdf => q<http://www.w3.org/1999/02/22-rdf-syntax-ns#>,
  rdfs => q<http://www.w3.org/2000/01/rdf-schema#>,
};

use Getopt::Long;
use Pod::Usage;
my %Opt;
GetOptions (
  'for=s' => \$Opt{For},
  'help' => \$Opt{help},
  'verbose!' => $Opt{verbose},
) or pod2usage (2);
if ($Opt{help}) {
  pod2usage (0);
  exit;
}
$Opt{file_name} = shift;

BEGIN {
require 'manakai/genlib.pl';
require 'manakai/dis.pl';
}
our $State;
our $result = '';

eval q{
  sub impl_msg ($;%) {
    warn shift () . "\n";
  }
} unless $Opt{verbose};

sub perl_change_package (%) {
  my %opt = @_;
  my $fn = $opt{full_name};
  unless ($fn eq $State->{ExpandedURI q<dis2pm:currentPackage>}) {
    $State->{ExpandedURI q<dis2pm:currentPackage>} = $fn;
    return perl_statement qq<package $fn>;
  } else {
    return '';
  }
} # perl_change_package

$State->{DefaultFor} = $Opt{For};

my $source = dis_load_module_file (module_file_name => $Opt{file_name},
                                   For => $Opt{For},
                                   use_default_for => 1);
$State->{for_def_required}->{$State->{DefaultFor}} ||= 1;

dis_check_undef_type_and_for () unless $Opt{no_undef_check};

if (dis_uri_for_match (ExpandedURI q<ManakaiDOM:Perl>, $State->{DefaultFor})) {
  dis_perl_init ($source, For => $State->{DefaultFor});
}

$State->{ExpandedURI q<dis2pm:currentPackage>} = 'main';
$result .= "#!/usr/bin/perl \n";
$result .= perl_comment q<This file is automatically generated from> . "\n" .
                        q<"> . $Opt{file_name} . q<" at > .
                        rfc3339_date (time) . qq<.\n> .
                        q<Don't edit by hand!>;
$result .= perl_statement q<use strict>;
$result .= perl_change_package
                  (full_name => $State->{Module}->{$State->{module}}
                                      ->{ExpandedURI q<dis2pm:packageName>});
$result .= perl_statement
                 perl_assign
                      perl_var (type => '$', local_name => 'VERSION',
                                scope => 'our')
                   => perl_literal version_date time;

for my $pack (values %{$State->{Module}->{$State->{module}}
                             ->{ExpandedURI q<dis2pm:package>}||{}}) {
  next unless defined $pack->{Name};
  if ({
       ExpandedURI q<ManakaiDOM:Class> => 1,
       ExpandedURI q<ManakaiDOM:IF> => 1,
       ExpandedURI q<ManakaiDOM:ExceptionClass> => 1,
       ExpandedURI q<ManakaiDOM:ExceptionIF> => 1,
       ExpandedURI q<ManakaiDOM:WarningIF> => 1,
      }->{$pack->{ExpandedURI q<dis2pm:type>}}) {
    ## Package name and version
    $result .= perl_change_package
                  (full_name => $pack->{ExpandedURI q<dis2pm:packageName>});
    $result .= perl_statement
                 perl_assign
                      perl_var (type => '$', local_name => 'VERSION',
                                scope => 'our')
                   => perl_literal version_date time;
    ## Inheritance
    my @isa;
    for my $uri (@{$pack->{ISA}||[]}, @{$pack->{Implement}||[]}) {
      my $pack = $State->{Type}->{$uri};
      if (defined $pack->{ExpandedURI q<dis2pm:packageName>}) {
        push @isa, $pack->{ExpandedURI q<dis2pm:packageName>};
      } else {
        impl_msg ("Inheriting package name for <$uri> not defined",
                  node => $pack->{src}) if $Opt{verbose};
      }
    }
    $result .= perl_inherit \@isa;
    ## Members
    if ({
         ExpandedURI q<ManakaiDOM:Class> => 1,
         ExpandedURI q<ManakaiDOM:ExceptionClass> => 1,
         ExpandedURI q<ManakaiDOM:WarningClass> => 1,
        }->{$pack->{ExpandedURI q<dis2pm:type>}}) {
      for my $method (values %{$pack->{ExpandedURI q<dis2pm:method>}}) {
        next unless defined $method->{Name};
        if ($method->{ExpandedURI q<dis2pm:type>} eq
            ExpandedURI q<ManakaiDOM:DOMMethod>) {
          $result .= perl_sub
                       (name => $method->{ExpandedURI q<dis2pm:methodName>},
                        code => '');
        } elsif ($method->{ExpandedURI q<dis2pm:type>} eq
                 ExpandedURI q<ManakaiDOM:DOMAttribute>) {
          $result .= perl_sub
                       (name => $method->{ExpandedURI q<dis2pm:methodName>},
                        'prototype'
                            => (defined $method->{ExpandedURI q<dis2pm:setter>}
                                               ->{Name} ? '$;$' : '$'),
                        code => '');
        }
      } # package method
      ## TODO: Const
    }    
  ## TODO: Const
  } # root object
}

## Export
if (keys %{$State->{perl_primary_module}->{perl_export_ok}||{}}) {
  $result .= perl_change_package
               full_name => $State->{perl_primary_module}->{perl_package_name};
  $result .= perl_statement 'require Exporter';
  $result .= perl_inherit ['Exporter'];
  $result .= perl_statement
               perl_assign
                    perl_var (type => '@', scope => 'our',
                              local_name => 'EXPORT_OK')
                 => '(' . perl_list (keys %{$State->{perl_primary_module}
                                                  ->{perl_export_ok}}) . ')';
  if (keys %{$State->{perl_primary_module}->{perl_export_tags}||{}}) {
    $result .= perl_statement
                 perl_assign
                       perl_var (type => '%', scope => 'our',
                                 local_name => 'EXPORT_TAGS')
                   => '(' . perl_list (map {
                         $_ => [keys %{$State->{perl_primary_module}
                                             ->{perl_export_tags}->{$_}}]
                      } keys %{$State->{perl_primary_module}
                                     ->{perl_export_tags}}) . ')';
  }
}

$result .= perl_statement 1;

output_result $result;

1;
1	wakaba	1.1	#!/usr/bin/perl -w
2			use strict;
3	wakaba	1.7	use Message::Util::QName::Filter {
4			d => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/lang#dis-->,
5			dis2pm => q<http://suika.fam.cx/~wakaba/archive/2004/11/8/dis2pm#>,
6			DOMCore => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/dom-core#>,
7			DOMMain => q<http://suika.fam.cx/~wakaba/archive/2004/dom/main#>,
8			lang => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/lang#>,
9			Perl => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/lang#Perl-->,
10			license => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/license#>,
11			ManakaiDOM => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/manakai-dom#>,
12			owl => q<http://www.w3.org/2002/07/owl#>,
13			rdf => q<http://www.w3.org/1999/02/22-rdf-syntax-ns#>,
14			rdfs => q<http://www.w3.org/2000/01/rdf-schema#>,
15			};
16	wakaba	1.1
17	wakaba	1.4	use Getopt::Long;
18	wakaba	1.5	use Pod::Usage;
19	wakaba	1.4	my %Opt;
20			GetOptions (
21	wakaba	1.5	'for=s' => \$Opt{For},
22	wakaba	1.4	'help' => \$Opt{help},
23	wakaba	1.7	'verbose!' => $Opt{verbose},
24	wakaba	1.4	) or pod2usage (2);
25			if ($Opt{help}) {
26			pod2usage (0);
27			exit;
28	wakaba	1.1	}
29	wakaba	1.7	$Opt{file_name} = shift;
30	wakaba	1.1
31			BEGIN {
32	wakaba	1.5	require 'manakai/genlib.pl';
33			require 'manakai/dis.pl';
34	wakaba	1.4	}
35	wakaba	1.5	our $State;
36	wakaba	1.7	our $result = '';
37	wakaba	1.4
38	wakaba	1.7	eval q{
39			sub impl_msg ($;%) {
40			warn shift () . "\n";
41	wakaba	1.1	}
42	wakaba	1.7	} unless $Opt{verbose};
43	wakaba	1.1
44	wakaba	1.5	sub perl_change_package (%) {
45	wakaba	1.7	my %opt = @_;
46			my $fn = $opt{full_name};
47			unless ($fn eq $State->{ExpandedURI q<dis2pm:currentPackage>}) {
48			$State->{ExpandedURI q<dis2pm:currentPackage>} = $fn;
49	wakaba	1.1	return perl_statement qq<package $fn>;
50			} else {
51			return '';
52			}
53	wakaba	1.5	} # perl_change_package
54	wakaba	1.1
55	wakaba	1.7	$State->{DefaultFor} = $Opt{For};
56	wakaba	1.6
57	wakaba	1.5	my $source = dis_load_module_file (module_file_name => $Opt{file_name},
58	wakaba	1.7	For => $Opt{For},
59	wakaba	1.5	use_default_for => 1);
60			$State->{for_def_required}->{$State->{DefaultFor}} \|\|= 1;
61	wakaba	1.3
62	wakaba	1.7	dis_check_undef_type_and_for () unless $Opt{no_undef_check};
63
64			if (dis_uri_for_match (ExpandedURI q<ManakaiDOM:Perl>, $State->{DefaultFor})) {
65			dis_perl_init ($source, For => $State->{DefaultFor});
66			}
67	wakaba	1.1
68	wakaba	1.7	$State->{ExpandedURI q<dis2pm:currentPackage>} = 'main';
69			$result .= "#!/usr/bin/perl \n";
70	wakaba	1.5	$result .= perl_comment q<This file is automatically generated from> . "\n" .
71			q<"> . $Opt{file_name} . q<" at > .
72			rfc3339_date (time) . qq<.\n> .
73			q<Don't edit by hand!>;
74			$result .= perl_statement q<use strict>;
75	wakaba	1.7	$result .= perl_change_package
76			(full_name => $State->{Module}->{$State->{module}}
77			->{ExpandedURI q<dis2pm:packageName>});
78			$result .= perl_statement
79			perl_assign
80			perl_var (type => '$', local_name => 'VERSION',
81			scope => 'our')
82			=> perl_literal version_date time;
83
84			for my $pack (values %{$State->{Module}->{$State->{module}}
85			->{ExpandedURI q<dis2pm:package>}\|\|{}}) {
86			next unless defined $pack->{Name};
87			if ({
88			ExpandedURI q<ManakaiDOM:Class> => 1,
89			ExpandedURI q<ManakaiDOM:IF> => 1,
90			ExpandedURI q<ManakaiDOM:ExceptionClass> => 1,
91			ExpandedURI q<ManakaiDOM:ExceptionIF> => 1,
92			ExpandedURI q<ManakaiDOM:WarningIF> => 1,
93			}->{$pack->{ExpandedURI q<dis2pm:type>}}) {
94			## Package name and version
95			$result .= perl_change_package
96			(full_name => $pack->{ExpandedURI q<dis2pm:packageName>});
97			$result .= perl_statement
98			perl_assign
99			perl_var (type => '$', local_name => 'VERSION',
100			scope => 'our')
101			=> perl_literal version_date time;
102			## Inheritance
103			my @isa;
104			for my $uri (@{$pack->{ISA}\|\|[]}, @{$pack->{Implement}\|\|[]}) {
105			my $pack = $State->{Type}->{$uri};
106			if (defined $pack->{ExpandedURI q<dis2pm:packageName>}) {
107			push @isa, $pack->{ExpandedURI q<dis2pm:packageName>};
108			} else {
109			impl_msg ("Inheriting package name for <$uri> not defined",
110			node => $pack->{src}) if $Opt{verbose};
111			}
112			}
113			$result .= perl_inherit \@isa;
114			## Members
115			if ({
116			ExpandedURI q<ManakaiDOM:Class> => 1,
117			ExpandedURI q<ManakaiDOM:ExceptionClass> => 1,
118			ExpandedURI q<ManakaiDOM:WarningClass> => 1,
119			}->{$pack->{ExpandedURI q<dis2pm:type>}}) {
120			for my $method (values %{$pack->{ExpandedURI q<dis2pm:method>}}) {
121			next unless defined $method->{Name};
122			if ($method->{ExpandedURI q<dis2pm:type>} eq
123			ExpandedURI q<ManakaiDOM:DOMMethod>) {
124			$result .= perl_sub
125			(name => $method->{ExpandedURI q<dis2pm:methodName>},
126			code => '');
127			} elsif ($method->{ExpandedURI q<dis2pm:type>} eq
128			ExpandedURI q<ManakaiDOM:DOMAttribute>) {
129			$result .= perl_sub
130			(name => $method->{ExpandedURI q<dis2pm:methodName>},
131			'prototype'
132			=> (defined $method->{ExpandedURI q<dis2pm:setter>}
133			->{Name} ? '$;$' : '$'),
134			code => '');
135			}
136			} # package method
137			## TODO: Const
138			}
139			## TODO: Const
140			} # root object
141			}
142	wakaba	1.1
143	wakaba	1.5	## Export
144			if (keys %{$State->{perl_primary_module}->{perl_export_ok}\|\|{}}) {
145			$result .= perl_change_package
146			full_name => $State->{perl_primary_module}->{perl_package_name};
147			$result .= perl_statement 'require Exporter';
148			$result .= perl_inherit ['Exporter'];
149			$result .= perl_statement
150			perl_assign
151			perl_var (type => '@', scope => 'our',
152			local_name => 'EXPORT_OK')
153			=> '(' . perl_list (keys %{$State->{perl_primary_module}
154			->{perl_export_ok}}) . ')';
155			if (keys %{$State->{perl_primary_module}->{perl_export_tags}\|\|{}}) {
156			$result .= perl_statement
157			perl_assign
158			perl_var (type => '%', scope => 'our',
159			local_name => 'EXPORT_TAGS')
160			=> '(' . perl_list (map {
161			$_ => [keys %{$State->{perl_primary_module}
162			->{perl_export_tags}->{$_}}]
163			} keys %{$State->{perl_primary_module}
164			->{perl_export_tags}}) . ')';
165	wakaba	1.1	}
166			}
167
168	wakaba	1.5	$result .= perl_statement 1;
169	wakaba	1.1
170	wakaba	1.5	output_result $result;
171	wakaba	1.1
172	wakaba	1.5	1;