manakai/bin/dis2pm.pl

#!/usr/bin/perl -w 
use strict;

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

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

my $ManakaiDOMModulePrefix = 'Message::DOM::';
sub perl_package_name (%) {
  my %opt = @_;
  my $r;
  if ($opt{if}) {
    $r = $ManakaiDOMModulePrefix . q<::IF::> . perl_name $opt{if};
  } elsif ($opt{iif}) {
    $r = $ManakaiDOMModulePrefix . q<::IIF::> . perl_name $opt{iif};
  } elsif ($opt{name} or $opt{name_with_condition}) {
    if ($opt{name_with_condition}) {
      if ($opt{name_with_condition} =~ /^([^:]+)::([^:]+)$/) {
        $opt{name} = $1;
        $opt{condition} = $2;
      } else {
        $opt{name} = $opt{name_with_condition};
      }
    } 
    $opt{name} = perl_name $opt{name};
    $opt{name} = $opt{prefix} . '::' . $opt{name} if $opt{prefix};
    $r = $ManakaiDOMModulePrefix . q<::> . $opt{name};
  } elsif ($opt{qname} or $opt{qname_with_condition}) {
    if ($opt{qname_with_condition}) {
      if ($opt{qname_with_condition} =~ /^(.+)::([^:]*)$/) {
        $opt{qname} = $1;
        $opt{condition} = $2;
      } else {
        $opt{qname} = $opt{qname_with_condition};
      }
    }
    if ($opt{qname} =~ /^([^:]*):(.*)$/) {
      $opt{ns_prefix} = $1;
      $opt{name} = $2;
    } else {
      $opt{ns_prefix} = '#default';
      $opt{name} = $opt{qname};
    }
    ## ISSUE: Prefix to ...
    #$r = ns_uri_to_perl_package_name (ns_prefix_to_uri ($opt{ns_prefix})) .
    #     '::' . $opt{name};
    $r = $ManakaiDOMModulePrefix . '::' . $opt{name};
  } elsif ($opt{if_qname} or $opt{if_qname_with_condition}) {
    if ($opt{if_qname_with_condition}) {
      if ($opt{if_qname_with_condition} =~ /^(.+)::([^:]*)$/) {
        $opt{if_qname} = $1;
        $opt{condition} = $2;
      } else {
        $opt{if_qname} = $opt{if_qname_with_condition};
      }
    }
    if ($opt{if_qname} =~ /^([^:]*):(.*)$/) {
      $opt{ns_prefix} = $1;
      $opt{name} = $2;
    } else {
      $opt{ns_prefix} = '#default';
      $opt{name} = $opt{if_qname};
    }
    ## ISSUE: Prefix to ...
    #$r = ns_uri_to_perl_package_name (ns_prefix_to_uri ($opt{ns_prefix})) .
    #     '::' . $opt{name};
    $r = $ManakaiDOMModulePrefix . '::IF::' . $opt{name};
  } elsif ($opt{full_name}) {
    $r = $opt{full_name};
  } else {
    valid_err q<$opt{name} is false>;
  }
  if ($opt{condition}) {
    $r = $r . '::' . perl_name $opt{condition};
  }
  if ($opt{is_internal}) {
    $r .= '::_internal';
    $r .= '_inherit' if $opt{is_for_inheriting};
  }
  $r;
} # perl_package_name

sub perl_change_package (%) {
  my $fn = perl_package_name @_;
  unless ($fn eq $State->{perl_current_package}) {
    $State->{perl_current_package} = $fn;
    return perl_statement qq<package $fn>;
  } else {
    return '';
  }
} # perl_change_package

sub dispm_root_node ($;%) {
  my ($node, %opt) = @_;
  my $r = '';
  for (@{$node->child_nodes}) {
    next unless $_->node_type eq '#element';
    next unless dis_node_for_match $_, $opt{For}, %opt;
    my $ln = $_->local_name;
    if ($ClassDefElementTypes->{$ln}) {
      $r .= dispm_classdefs_element ($_, %opt);
    } elsif ({qw/Const 1/}->{$ln}) {
      ## TODO: 
    } elsif ({qw/Module 1 Namespace 1/}->{$ln}) {
      # 
    } else {
      valid_err q<Unknown element type>, node => $_;
    }
  }
  $r;
} # dispm_root_node

sub dispm_classdefs_element ($;%) {
  my ($node, %opt) = @_;
  my $r = '';
  my $ln = $node->local_name;
  for ([ExpandedURI q<ManakaiDOM:Class>, \&dispm_classdef_element],
       [ExpandedURI q<ManakaiDOM:IF>, \&dispm_ifdef_element],
       [ExpandedURI q<ManakaiDOM:Exception>, \&dispm_exceptiondef_element],
       [ExpandedURI q<ManakaiDOM:Warning>, \&dispm_warningdef_element],
       [ExpandedURI q<ManakaiDOM:DataType>, \&dispm_datatypedef_element],
       [ExpandedURI q<ManakaiDOM:ConstGroup>, \&dispm_constgroup_element]) {
    my $type = dis_get_attr_node (%opt, parent => $node,
                                  name => 'Type');
    if (defined $type) {
      ## Matched explicitly or implicitly
      if ($type ? dis_uri_ctype_match ($type->value, $_->[0], %opt) : 1) {
        $r .= $_->[1]->($node, %opt);
      }
    }
  } 
  return $r;
} # dispm_classdefs_element

sub dispm_classdef_element ($;%) {
  my ($node, %opt) = @_;
  my $r = '';
  return $r;
} # dispm_classdef_element

sub dispm_ifdef_element ($;%) {
  my ($node, %opt) = @_;
  my $r = '';
  return $r;
} # dispm_ifdef_element

sub dispm_exceptiondef_element ($;%) {
  my ($node, %opt) = @_;
  my $r = '';
  return $r;
} # dispm_exceptiondef_element

sub dispm_warningdef_element ($;%) {
  my ($node, %opt) = @_;
  my $r = '';
  return $r;
} # dispm_warningdef_element

sub dispm_datatypedef_element ($;%) {
  my ($node, %opt) = @_;
  my $r = '';
  return $r;
} # dispm_datatypedef_element

sub dispm_constgroupdef_element ($;%) {
  my ($node, %opt) = @_;
  my $r = '';
  return $r;
} # dispm_constgroupdef_element


$Opt{file_name} = shift;

$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 ();
$State->{perl_primary_module} = $State->{Module}->{$State->{module}};

my $result = '';
$State->{perl_current_package} = 'main';
$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>;
$State->{perl_defined_package}
      ->{$State->{perl_primary_module}->{perl_package_name}} = 1;
$result .= dispm_root_node ($source);

## 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}}) . ')';
  }
}

## Packages
{
  my $list = join ', ', map {'$'.$_.'::VERSION'}
                        sort keys %{$State->{perl_defined_package}};
  my $date = perl_literal version_date time;
  $result .= qq{
               for ($list) {
                 \$_ = $date;
               }
  };
}
$result .= perl_statement 1;

output_result $result;

1;
1	wakaba	1.1	#!/usr/bin/perl -w
2			use strict;
3
4	wakaba	1.4	use Getopt::Long;
5	wakaba	1.5	use Pod::Usage;
6	wakaba	1.4	my %Opt;
7			GetOptions (
8	wakaba	1.5	'for=s' => \$Opt{For},
9	wakaba	1.4	'help' => \$Opt{help},
10			) or pod2usage (2);
11			if ($Opt{help}) {
12			pod2usage (0);
13			exit;
14	wakaba	1.1	}
15
16			BEGIN {
17	wakaba	1.5	require 'manakai/genlib.pl';
18			require 'manakai/dis.pl';
19	wakaba	1.4	}
20	wakaba	1.5	our $State;
21			our $ClassDefElementTypes;
22	wakaba	1.4
23	wakaba	1.5	my $ManakaiDOMModulePrefix = 'Message::DOM::';
24	wakaba	1.1	sub perl_package_name (%) {
25			my %opt = @_;
26			my $r;
27			if ($opt{if}) {
28			$r = $ManakaiDOMModulePrefix . q<::IF::> . perl_name $opt{if};
29			} elsif ($opt{iif}) {
30			$r = $ManakaiDOMModulePrefix . q<::IIF::> . perl_name $opt{iif};
31			} elsif ($opt{name} or $opt{name_with_condition}) {
32			if ($opt{name_with_condition}) {
33			if ($opt{name_with_condition} =~ /^([^:]+)::([^:]+)$/) {
34			$opt{name} = $1;
35			$opt{condition} = $2;
36			} else {
37			$opt{name} = $opt{name_with_condition};
38			}
39			}
40			$opt{name} = perl_name $opt{name};
41			$opt{name} = $opt{prefix} . '::' . $opt{name} if $opt{prefix};
42			$r = $ManakaiDOMModulePrefix . q<::> . $opt{name};
43			} elsif ($opt{qname} or $opt{qname_with_condition}) {
44			if ($opt{qname_with_condition}) {
45			if ($opt{qname_with_condition} =~ /^(.+)::([^:]*)$/) {
46			$opt{qname} = $1;
47			$opt{condition} = $2;
48			} else {
49			$opt{qname} = $opt{qname_with_condition};
50			}
51			}
52			if ($opt{qname} =~ /^([^:]):(.)$/) {
53			$opt{ns_prefix} = $1;
54			$opt{name} = $2;
55			} else {
56	wakaba	1.5	$opt{ns_prefix} = '#default';
57	wakaba	1.1	$opt{name} = $opt{qname};
58			}
59			## ISSUE: Prefix to ...
60			#$r = ns_uri_to_perl_package_name (ns_prefix_to_uri ($opt{ns_prefix})) .
61			# '::' . $opt{name};
62			$r = $ManakaiDOMModulePrefix . '::' . $opt{name};
63			} elsif ($opt{if_qname} or $opt{if_qname_with_condition}) {
64			if ($opt{if_qname_with_condition}) {
65			if ($opt{if_qname_with_condition} =~ /^(.+)::([^:]*)$/) {
66			$opt{if_qname} = $1;
67			$opt{condition} = $2;
68			} else {
69			$opt{if_qname} = $opt{if_qname_with_condition};
70			}
71			}
72			if ($opt{if_qname} =~ /^([^:]):(.)$/) {
73			$opt{ns_prefix} = $1;
74			$opt{name} = $2;
75			} else {
76	wakaba	1.5	$opt{ns_prefix} = '#default';
77	wakaba	1.1	$opt{name} = $opt{if_qname};
78			}
79			## ISSUE: Prefix to ...
80			#$r = ns_uri_to_perl_package_name (ns_prefix_to_uri ($opt{ns_prefix})) .
81			# '::' . $opt{name};
82			$r = $ManakaiDOMModulePrefix . '::IF::' . $opt{name};
83			} elsif ($opt{full_name}) {
84			$r = $opt{full_name};
85			} else {
86			valid_err q<$opt{name} is false>;
87			}
88			if ($opt{condition}) {
89			$r = $r . '::' . perl_name $opt{condition};
90			}
91			if ($opt{is_internal}) {
92			$r .= '::_internal';
93			$r .= '_inherit' if $opt{is_for_inheriting};
94			}
95			$r;
96	wakaba	1.5	} # perl_package_name
97	wakaba	1.1
98	wakaba	1.5	sub perl_change_package (%) {
99	wakaba	1.1	my $fn = perl_package_name @_;
100	wakaba	1.5	unless ($fn eq $State->{perl_current_package}) {
101			$State->{perl_current_package} = $fn;
102	wakaba	1.1	return perl_statement qq<package $fn>;
103			} else {
104			return '';
105			}
106	wakaba	1.5	} # perl_change_package
107	wakaba	1.1
108	wakaba	1.5	sub dispm_root_node ($;%) {
109			my ($node, %opt) = @_;
110			my $r = '';
111			for (@{$node->child_nodes}) {
112			next unless $_->node_type eq '#element';
113			next unless dis_node_for_match $_, $opt{For}, %opt;
114			my $ln = $_->local_name;
115			if ($ClassDefElementTypes->{$ln}) {
116			$r .= dispm_classdefs_element ($_, %opt);
117			} elsif ({qw/Const 1/}->{$ln}) {
118			## TODO:
119			} elsif ({qw/Module 1 Namespace 1/}->{$ln}) {
120			#
121	wakaba	1.1	} else {
122	wakaba	1.5	valid_err q<Unknown element type>, node => $_;
123	wakaba	1.1	}
124			}
125			$r;
126	wakaba	1.5	} # dispm_root_node
127	wakaba	1.1
128	wakaba	1.5	sub dispm_classdefs_element ($;%) {
129			my ($node, %opt) = @_;
130			my $r = '';
131			my $ln = $node->local_name;
132			for ([ExpandedURI q<ManakaiDOM:Class>, \&dispm_classdef_element],
133			[ExpandedURI q<ManakaiDOM:IF>, \&dispm_ifdef_element],
134			[ExpandedURI q<ManakaiDOM:Exception>, \&dispm_exceptiondef_element],
135			[ExpandedURI q<ManakaiDOM:Warning>, \&dispm_warningdef_element],
136			[ExpandedURI q<ManakaiDOM:DataType>, \&dispm_datatypedef_element],
137			[ExpandedURI q<ManakaiDOM:ConstGroup>, \&dispm_constgroup_element]) {
138			my $type = dis_get_attr_node (%opt, parent => $node,
139			name => 'Type');
140			if (defined $type) {
141			## Matched explicitly or implicitly
142			if ($type ? dis_uri_ctype_match ($type->value, $_->[0], %opt) : 1) {
143			$r .= $_->[1]->($node, %opt);
144			}
145			}
146			}
147			return $r;
148			} # dispm_classdefs_element
149	wakaba	1.3
150	wakaba	1.5	sub dispm_classdef_element ($;%) {
151			my ($node, %opt) = @_;
152			my $r = '';
153			return $r;
154			} # dispm_classdef_element
155	wakaba	1.1
156	wakaba	1.5	sub dispm_ifdef_element ($;%) {
157			my ($node, %opt) = @_;
158			my $r = '';
159			return $r;
160			} # dispm_ifdef_element
161	wakaba	1.1
162	wakaba	1.5	sub dispm_exceptiondef_element ($;%) {
163			my ($node, %opt) = @_;
164			my $r = '';
165			return $r;
166			} # dispm_exceptiondef_element
167	wakaba	1.1
168	wakaba	1.5	sub dispm_warningdef_element ($;%) {
169	wakaba	1.1	my ($node, %opt) = @_;
170			my $r = '';
171	wakaba	1.5	return $r;
172			} # dispm_warningdef_element
173	wakaba	1.1
174	wakaba	1.5	sub dispm_datatypedef_element ($;%) {
175	wakaba	1.1	my ($node, %opt) = @_;
176	wakaba	1.5	my $r = '';
177			return $r;
178			} # dispm_datatypedef_element
179	wakaba	1.1
180	wakaba	1.5	sub dispm_constgroupdef_element ($;%) {
181	wakaba	1.1	my ($node, %opt) = @_;
182	wakaba	1.5	my $r = '';
183			return $r;
184			} # dispm_constgroupdef_element
185	wakaba	1.1
186	wakaba	1.3
187	wakaba	1.5	$Opt{file_name} = shift;
188	wakaba	1.3
189	wakaba	1.5	$State->{DefaultFor} = $Opt{For};
190			my $source = dis_load_module_file (module_file_name => $Opt{file_name},
191			for => $Opt{For},
192			use_default_for => 1);
193			$State->{for_def_required}->{$State->{DefaultFor}} \|\|= 1;
194	wakaba	1.3
195	wakaba	1.5	dis_check_undef_type_and_for ();
196			$State->{perl_primary_module} = $State->{Module}->{$State->{module}};
197	wakaba	1.1
198	wakaba	1.5	my $result = '';
199			$State->{perl_current_package} = 'main';
200			$result .= perl_comment q<This file is automatically generated from> . "\n" .
201			q<"> . $Opt{file_name} . q<" at > .
202			rfc3339_date (time) . qq<.\n> .
203			q<Don't edit by hand!>;
204	wakaba	1.1
205	wakaba	1.5	$result .= perl_statement q<use strict>;
206			$State->{perl_defined_package}
207			->{$State->{perl_primary_module}->{perl_package_name}} = 1;
208			$result .= dispm_root_node ($source);
209	wakaba	1.1
210	wakaba	1.5	## Export
211			if (keys %{$State->{perl_primary_module}->{perl_export_ok}\|\|{}}) {
212			$result .= perl_change_package
213			full_name => $State->{perl_primary_module}->{perl_package_name};
214			$result .= perl_statement 'require Exporter';
215			$result .= perl_inherit ['Exporter'];
216			$result .= perl_statement
217			perl_assign
218			perl_var (type => '@', scope => 'our',
219			local_name => 'EXPORT_OK')
220			=> '(' . perl_list (keys %{$State->{perl_primary_module}
221			->{perl_export_ok}}) . ')';
222			if (keys %{$State->{perl_primary_module}->{perl_export_tags}\|\|{}}) {
223			$result .= perl_statement
224			perl_assign
225			perl_var (type => '%', scope => 'our',
226			local_name => 'EXPORT_TAGS')
227			=> '(' . perl_list (map {
228			$_ => [keys %{$State->{perl_primary_module}
229			->{perl_export_tags}->{$_}}]
230			} keys %{$State->{perl_primary_module}
231			->{perl_export_tags}}) . ')';
232	wakaba	1.1	}
233			}
234
235	wakaba	1.5	## Packages
236			{
237			my $list = join ', ', map {'$'.$_.'::VERSION'}
238			sort keys %{$State->{perl_defined_package}};
239			my $date = perl_literal version_date time;
240			$result .= qq{
241			for ($list) {
242			\$_ = $date;
243			}
244			};
245	wakaba	1.1	}
246	wakaba	1.5	$result .= perl_statement 1;
247	wakaba	1.1
248	wakaba	1.5	output_result $result;
249	wakaba	1.1
250	wakaba	1.5	1;