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.6
109
110	wakaba	1.5	sub dispm_root_node ($;%) {
111			my ($node, %opt) = @_;
112			my $r = '';
113			for (@{$node->child_nodes}) {
114			next unless $_->node_type eq '#element';
115			next unless dis_node_for_match $_, $opt{For}, %opt;
116			my $ln = $_->local_name;
117			if ($ClassDefElementTypes->{$ln}) {
118			$r .= dispm_classdefs_element ($_, %opt);
119			} elsif ({qw/Const 1/}->{$ln}) {
120			## TODO:
121			} elsif ({qw/Module 1 Namespace 1/}->{$ln}) {
122			#
123	wakaba	1.1	} else {
124	wakaba	1.5	valid_err q<Unknown element type>, node => $_;
125	wakaba	1.1	}
126			}
127			$r;
128	wakaba	1.5	} # dispm_root_node
129	wakaba	1.1
130	wakaba	1.5	sub dispm_classdefs_element ($;%) {
131			my ($node, %opt) = @_;
132			my $r = '';
133			my $ln = $node->local_name;
134			for ([ExpandedURI q<ManakaiDOM:Class>, \&dispm_classdef_element],
135			[ExpandedURI q<ManakaiDOM:IF>, \&dispm_ifdef_element],
136			[ExpandedURI q<ManakaiDOM:Exception>, \&dispm_exceptiondef_element],
137			[ExpandedURI q<ManakaiDOM:Warning>, \&dispm_warningdef_element],
138			[ExpandedURI q<ManakaiDOM:DataType>, \&dispm_datatypedef_element],
139			[ExpandedURI q<ManakaiDOM:ConstGroup>, \&dispm_constgroup_element]) {
140			my $type = dis_get_attr_node (%opt, parent => $node,
141			name => 'Type');
142			if (defined $type) {
143			## Matched explicitly or implicitly
144			if ($type ? dis_uri_ctype_match ($type->value, $_->[0], %opt) : 1) {
145			$r .= $_->[1]->($node, %opt);
146			}
147			}
148			}
149			return $r;
150			} # dispm_classdefs_element
151	wakaba	1.3
152	wakaba	1.5	sub dispm_classdef_element ($;%) {
153			my ($node, %opt) = @_;
154			my $r = '';
155			return $r;
156			} # dispm_classdef_element
157	wakaba	1.1
158	wakaba	1.5	sub dispm_ifdef_element ($;%) {
159			my ($node, %opt) = @_;
160			my $r = '';
161			return $r;
162			} # dispm_ifdef_element
163	wakaba	1.1
164	wakaba	1.5	sub dispm_exceptiondef_element ($;%) {
165			my ($node, %opt) = @_;
166			my $r = '';
167			return $r;
168			} # dispm_exceptiondef_element
169	wakaba	1.1
170	wakaba	1.5	sub dispm_warningdef_element ($;%) {
171	wakaba	1.1	my ($node, %opt) = @_;
172			my $r = '';
173	wakaba	1.5	return $r;
174			} # dispm_warningdef_element
175	wakaba	1.1
176	wakaba	1.5	sub dispm_datatypedef_element ($;%) {
177	wakaba	1.1	my ($node, %opt) = @_;
178	wakaba	1.5	my $r = '';
179			return $r;
180			} # dispm_datatypedef_element
181	wakaba	1.1
182	wakaba	1.5	sub dispm_constgroupdef_element ($;%) {
183	wakaba	1.1	my ($node, %opt) = @_;
184	wakaba	1.5	my $r = '';
185			return $r;
186			} # dispm_constgroupdef_element
187	wakaba	1.1
188	wakaba	1.3
189	wakaba	1.5	$Opt{file_name} = shift;
190	wakaba	1.3
191	wakaba	1.5	$State->{DefaultFor} = $Opt{For};
192			my $source = dis_load_module_file (module_file_name => $Opt{file_name},
193			for => $Opt{For},
194			use_default_for => 1);
195			$State->{for_def_required}->{$State->{DefaultFor}} \|\|= 1;
196	wakaba	1.3
197	wakaba	1.5	dis_check_undef_type_and_for ();
198			$State->{perl_primary_module} = $State->{Module}->{$State->{module}};
199	wakaba	1.1
200	wakaba	1.5	my $result = '';
201			$State->{perl_current_package} = 'main';
202			$result .= perl_comment q<This file is automatically generated from> . "\n" .
203			q<"> . $Opt{file_name} . q<" at > .
204			rfc3339_date (time) . qq<.\n> .
205			q<Don't edit by hand!>;
206	wakaba	1.1
207	wakaba	1.5	$result .= perl_statement q<use strict>;
208			$State->{perl_defined_package}
209			->{$State->{perl_primary_module}->{perl_package_name}} = 1;
210			$result .= dispm_root_node ($source);
211	wakaba	1.1
212	wakaba	1.5	## Export
213			if (keys %{$State->{perl_primary_module}->{perl_export_ok}\|\|{}}) {
214			$result .= perl_change_package
215			full_name => $State->{perl_primary_module}->{perl_package_name};
216			$result .= perl_statement 'require Exporter';
217			$result .= perl_inherit ['Exporter'];
218			$result .= perl_statement
219			perl_assign
220			perl_var (type => '@', scope => 'our',
221			local_name => 'EXPORT_OK')
222			=> '(' . perl_list (keys %{$State->{perl_primary_module}
223			->{perl_export_ok}}) . ')';
224			if (keys %{$State->{perl_primary_module}->{perl_export_tags}\|\|{}}) {
225			$result .= perl_statement
226			perl_assign
227			perl_var (type => '%', scope => 'our',
228			local_name => 'EXPORT_TAGS')
229			=> '(' . perl_list (map {
230			$_ => [keys %{$State->{perl_primary_module}
231			->{perl_export_tags}->{$_}}]
232			} keys %{$State->{perl_primary_module}
233			->{perl_export_tags}}) . ')';
234	wakaba	1.1	}
235			}
236
237	wakaba	1.5	## Packages
238			{
239			my $list = join ', ', map {'$'.$_.'::VERSION'}
240			sort keys %{$State->{perl_defined_package}};
241			my $date = perl_literal version_date time;
242			$result .= qq{
243			for ($list) {
244			\$_ = $date;
245			}
246			};
247	wakaba	1.1	}
248	wakaba	1.5	$result .= perl_statement 1;
249	wakaba	1.1
250	wakaba	1.5	output_result $result;
251	wakaba	1.1
252	wakaba	1.5	1;