manakai/bin/cdis2pm.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#>,
  MDOMX => q<http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#>,
  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;
use Storable;
my %Opt;
GetOptions (
  'for=s' => \$Opt{For},
  'help' => \$Opt{help},
  'module-name=s' => \$Opt{module_name},
  'module-uri=s' => \$Opt{module_uri},
  'verbose!' => $Opt{verbose},
) or pod2usage (2);
pod2usage ({-exitval => 0, -verbose => 1}) if $Opt{help};
$Opt{file_name} = shift;
pod2usage ({-exitval => 2, -verbose => 0}) unless $Opt{file_name};
pod2usage (2) if not $Opt{module_uri} and not $Opt{module_name};

BEGIN {
require 'manakai/genlib.pl';
require 'manakai/dis.pl';
}
our $State = retrieve ($Opt{file_name})
     or die "$0: $Opt{file_name}: Cannot load";
our $result = '';

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

sub perl_change_package (%) {
  my %opt = @_;
  my $fn = $opt{full_name};
  impl_err (qq<$fn: Bad package name>) unless $fn;
  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

=item $code = dispm_perl_throws (%opt)

Generates a code to throw an exception.

=cut

sub dispm_perl_throws (%) {
  my %opt = @_;
  my $x = $State->{Type}->{$opt{class}};
  my $r = 'report ';
  unless (defined $x->{Name}) {
    $opt{class} = dis_typeforuris_to_uri ($opt{class}, $opt{class_for}, %opt);
    $x = $State->{Type}->{$opt{class}};
  }
  valid_err (qq<Exception class <$opt{class}> is not defined>,
             node => $opt{node}) unless defined $x->{Name};
  if ($x->{ExpandedURI q<dis2pm:type>} and
      {
        ExpandedURI q<ManakaiDOM:ExceptionClass> => 1,
        ExpandedURI q<ManakaiDOM:WarningClass> => 1,
      }->{$x->{ExpandedURI q<dis2pm:type>}}) {
    $r .= $x->{ExpandedURI q<dis2pm:packageName>} . ' ' .
          perl_list -type => $opt{type},
                    -object => perl_code_literal ('$self'),
                    %{$opt{xparam} || {}};
  } else {
    no warnings 'uninitialized';
    valid_err (qq{Resource <$opt{class}> (<$x->{ExpandedURI q<dis2pm:type>}>) }.
               q<is neither exception class nor >.
               q<warning class>, node => $opt{node});
  }
  return $r;
} # dispm_perl_throw

{
use re 'eval';
my $RegBlockContent;
$RegBlockContent = qr/(?>[^{}\\]*)(?>(?>[^{}\\]+|\\.|\{(??{$RegBlockContent})\})*)/s;
## Defined by genlib.pl but overridden.
sub perl_code ($;%) {
  my ($s, %opt) = @_;
  valid_err q<Uninitialized value in perl_code>,
    node => $opt{node} unless defined $s;
  local $State->{Namespace}
    = $State->{Module}->{$opt{resource}->{parentModule}}->{nsBinding};
  $s =~ s[<Q:([^<>]+)>|\b(null|true|false)\b][
    my ($q, $l) = ($1, $2);
    if (defined $q) {
      if ($q =~ /\}/) {
        valid_warn qq<QName "$q" has a "}" - it might be a typo>;
      }
      perl_literal (dis_qname_to_uri ($q, %opt));
    } else {
      {true => 1, false => 0, null => 'undef'}->{$l};
    }
  ]ge;
  ## TODO: Ensure Message::Util::Error imported if "try"ing.
  ## ISSUE: __FILE__ & __LINE__ will break if multiline substition happens.
  $s =~ s{
    \b__([A-Z]+)
    (?:\{($RegBlockContent)\})?
    __\b
  }{
    my ($name, $data) = ($1, $2);
    my $r;
    if ($name eq 'XCLASS' or      ## Manakai DOM Class
        $name eq 'XSUPER' or      ## Manakai DOM Class (internal)
        $name eq 'XIIF' or        ## DOM Interface + Internal interface & prop
        $name eq 'XIF') {         ## DOM Interface
      #local $Status->{condition} = $Status->{condition};
      if ($data =~ s/::([^:]*)$//) {
        #$Status->{condition} = $1;
      }
      #$r = perl_package_name {qw/CLASS name SUPER name IIF iif IF if/}->{$name}
      #                                   => $data,
      #                       is_internal => {qw/SUPER 1/}->{$name},
                             #condition => $Status->{condition};
    } elsif ($name eq 'XINT') {    ## Internal Method / Attr Name
      if (defined $data) {
        if ($data =~ /^{($RegBlockContent)}$/o) {
          $data = $1;
          my $name = $1 if $data =~ s/^\s*(\w+)\s*(?:$|:\s*)// or
            valid_err qq<Syntax of preprocessing macro "INT" is invalid>,
            node => $opt{node};
          #local $Status->{preprocess_variable}
          #                 = {%{$Status->{preprocess_variable}||{}}};
          while ($data =~ /\G(\S+)\s*(?:=>\s*(\S+)\s*)?(?:,\s*|$)/g) {
            my ($n, $v) = ($1, defined $2 ? $2 : 1);
            for ($n, $v) {
              s/^'([^']+)'$/$1/; ## ISSUE: Doesn't support quoted-'
            }
            #$Status->{preprocess_variable}->{$n} = $v;
          }
          valid_err q<Preprocessing macro INT{} cannot be used here>
            unless $opt{internal};
          $r = perl_comment ("INT: $name").
               $opt{internal}->($name);
        } elsif ($data =~ s/^SP://) {
          $r = '___'.$data;
        } else {
          $r = perl_internal_name $data;
        }
      } else {
        valid_err q<Preprocessing macro INT cannot be used here>
          unless $opt{internal};
        $r = $opt{internal}->();
      }
    } elsif ($name eq 'DEEP') {   ## Deep Method Call
      $r = 'do { local $Error::Depth = $Error::Depth + 1;' . perl_code ($data) .
           '}';
    } elsif ($name eq 'XEXCEPTION' or $name eq 'XWARNING') {
                                  ## Raising an Exception or Warning
      if ($data =~ s/^\s*(\w+)\s*\.\s*(\w+)\s*(?:\.\s*([\w:]+)\s*)?(?:::\s*|$)//) {
        $r = perl_exception (level => $name,
                             class => $1,
                             type => $2,
                             subtype => $3,
                             param => perl_code $data);
      } else {
        valid_err qq<Exception type and name required: "$data">,
          node => $opt{node};
      }      
    } elsif ($name eq 'XCODE') { # Built-in code
      my ($nm, %param);
      if ($data =~ s/^(\w+)\s*(?::\s*|$)//) {
        $nm = $1;
      } elsif ($data =~ s/^<([^<>]+)>\s*(?::\s*|$)//) {
        $nm = $1;
      } else {
        valid_err q<Built-in code name required>;
      }
      while ($data =~ /\G(\S+)\s*=>\s*(\S+)\s*(?:,\s*|$)/g) {
        $param{$1} = $2;
      }
      $r = perl_builtin_code ($nm, condition => $opt{condition}, %param);
    } elsif ($name eq 'XPACKAGE' and $data) {
      if ($data eq 'Global') {
        #$r = $ManakaiDOMModulePrefix;
      } else {
        valid_err qq<PACKAGE "$data" not supported>;
      }
    } elsif ($name eq 'XREQUIRE') {
      #$r = perl_statement (q<require >. perl_package_name name => $data);
    } elsif ($name eq 'XWHEN') {
      if ($data =~ s/^\s*IS\s*\{($RegBlockContent)\}::\s*//o) {
        my $v = $1;
        if ($v =~ /^\s*'([^']+)'\s*$/) { ## ISSUE: Doesn't support quoted-'
          if ($State->{preprocess_variable}->{$1}) {
            $r = perl_code ($data, %opt);
          } else {
            $r = perl_comment ($data);
          }
        } else {
          valid_err qq<WHEN-IS condition "$v" is invalid>,
            node => $opt{node};
        }
      } else {
        valid_err qq<Syntax for preprocessing macro "WHEN" is invalid>,
          node => $opt{node};
      }
    } elsif ($name eq 'FILE' or $name eq 'LINE' or $name eq 'PACKAGE') {
      $r = qq<__${name}__>;
    } else {
      $r = $&;
      #valid_err qq<Preprocessing macro "$name" not supported>;
    }
    $r;
  }goex;
  $s;
}
}

## Defined in genlib.pl but overridden.
sub perl_code_source ($%) {
  my ($s, %opt) = @_;
  my $npk = [qw/Name QName Label/];
  my $f1 = sprintf q<File <%s> Node <%s> [Chunk #%d]>,
    $opt{file} || $State->{Module}->{$opt{resource}->{parentModule}}->{FileName},
    $opt{path} || ($opt{resource}->{src}
                     ? $opt{resource}->{src}->node_path (key => $npk)
                     : $opt{node} ? $opt{node}->node_path (key => $npk)
                                  : 'x:unknown ()'),
    ++($State->{ExpandedURI q<dis2pm:generatedChunk>} ||= 0);
  my $f2 = sprintf q<Module <%s> [Chunk #%d]>,
    $opt{file} || $State->{Module}->{$State->{module}}->{URI},
    ++($State->{ExpandedURI q<dis2pm:generatedChunk>} ||= 0);
  $f1 =~ s/"/\"/g; $f2 =~ s/"/\"/g;
  sprintf qq<\n#line %d "%s"\n%s\n#line 1 "%s"\n>,
                 $opt{line} || 1, $f1, $s, $f2;
}


=item $code = dispm_get_code (resource => $res, %opt)

Generates a Perl code fragment from resource(s).

=cut

sub dispm_get_code (%) {
  my %opt = @_;
  my $key = $opt{ExpandedURI q<dis2pm:DefKeyName>} || ExpandedURI q<d:Def>;
  my $n = dis_get_attr_node (%opt, parent => $opt{resource}->{src},
                             name => {uri => $key},
                             ContentType => ExpandedURI q<lang:Perl>);
  if ($n) {
    return perl_code_source
             perl_code ($n->value,
                        %opt, node => $n),
             %opt,
             node => $n;
  }
  return undef;
} # dispm_get_code

=item $code = dispm_get_value (%opt)

Gets value property and returns it as a Perl code fragment.

=cut

sub dispm_get_value (%) {
  my %opt = @_;
  my $key = $opt{ExpandedURI q<dis2pm:DefKeyName>} || ExpandedURI q<d:Value>;
  my $vt = $opt{ExpandedURI q<dis2pm:valueType>} || ExpandedURI q<DOMMain:any>;
  my $n = dis_get_elements_nodes (%opt, parent => $opt{resource}->{src},
                                  name => {uri => $key});
  for my $n (@$n) {
    my $t = dis_get_attr_node (%opt, parent => $n, name => 'ContentType');
    my $type;
    if ($t) {
      $type = dis_qname_to_uri ($t->value, %opt, node => $t);
    } else {
      $type = ExpandedURI q<DOMMain:any>;  ## ISSUE: Is this appropriate type?
    }
    valid_err (qq<Type <$type> is not defined>, node => $t || $n)
      unless defined $State->{Type}->{$type}->{Name};
    
    if (dis_uri_ctype_match (ExpandedURI q<lang:Perl>, $type, %opt)) {
      ## ISSUE: Is some pre-process required?
      return $n->value;
    } 
  }

  ## No explicit value specified
  if ($opt{ExpandedURI q<dis2pm:useDefaultValue>}) {
    if (dis_uri_ctype_match (ExpandedURI q<DOMMain:DOMString>, $vt, %opt)) {
      return q<"">;
    }
  }
  return undef;
} # dispm_get_value


## Outputed module and "For"
my $mf = dis_get_module_uri (module_name => $Opt{module_name},
                             module_uri => $Opt{module_uri},
                             For => $Opt{For});
$State->{DefaultFor} = $mf->{For};
$State->{module} = $mf->{module};

valid_err
 (qq{Perl module <$State->{module}> not defined for <$State->{DefaultFor}>},
  node => $State->{Module}->{$State->{module}}->{src})
    unless $State->{Module}->{$State->{module}}
                 ->{ExpandedURI q<dis2pm:packageName>};

$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_comment qq{Module <$State->{module}>};
$result .= perl_comment qq{For <$State->{DefaultFor}>};
$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};
      }
    }
    $isa = array_uniq $isa;
    $result .= perl_inherit $isa;
    $result .= '$' . $_ . "::;\n" for @$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>) {
          my $proto = '$';
          my @param = ('self');
          my $param_opt = 0;
          for my $param (@{$method->{ExpandedURI q<dis2pm:param>}||[]}) {
            if ($param->{ExpandedURI q<dis2pm:nullable>}) {
              $proto .= ';' unless $param_opt;
              $param_opt++;
            }
            $proto .= '$';
            push @param, $param->{ExpandedURI q<dis2pm:paramName>};
          }
          my $code = dispm_get_code
                       (resource => $method->{ExpandedURI q<dis2pm:return>});
          if (defined $code) {
            my $my = perl_statement ('my ('.join (", ", map {"\$$_"} @param).
                                     ') = @_');
            my $return = defined $method->{ExpandedURI q<dis2pm:return>}->{Name}
                            ? $method->{ExpandedURI q<dis2pm:return>} : undef;
            if ($return->{ExpandedURI q<d:actualType>} ? 1 : 0) {
              my $default = dispm_get_value
                           (resource => $return,
                            ExpandedURI q<dis2pm:ValueKeyName>
                                => ExpandedURI q<d:DefaultValue>,
                            ExpandedURI q<dis2pm:useDefaultValue> => 1,
                            ExpandedURI q<dis2pm:valueType>
                              => $return->{ExpandedURI q<d:actualType>});
              $code = $my . 
                      perl_statement
                        (defined $default ? 'my $r = '.$default : 'my $r').
                      $code . "\n" .
                      perl_statement ('$r');
            } else {
              $code = $my . $code;
            }
          } else { ## Code not defined
            my $for = [keys %{$method->{For}}]->[0];
            unless (dis_uri_for_match (ExpandedURI q<ManakaiDOM:ManakaiDOM1>,
                                       $for, node => $method->{src})) {
              $for = ExpandedURI q<ManakaiDOM:ManakaiDOMLatest>;
            }
            $code = perl_statement
                      dispm_perl_throws
                        class => ExpandedURI q<DOMCore:ManakaiDOMException>,
                        class_for => $for,
                        type => 'NOT_SUPPORTED_ERR',
                        subtype =>
                          ExpandedURI q<MDOMX:MDOM_IMPL_METHOD_NOT_IMPLEMENTED>,
                        xparam => {
                          ExpandedURI q<MDOMX:class>
                                 => $pack->{ExpandedURI q<dis2pm:packageName>},
                          ExpandedURI q<MDOMX:method>
                                 => $method->{ExpandedURI q<dis2pm:methodName>},
                        };
          }
          $result .= perl_sub
                       (name => $method->{ExpandedURI q<dis2pm:methodName>},
                        code => $code, prototype => $proto);
        } elsif ($method->{ExpandedURI q<dis2pm:type>} eq
                 ExpandedURI q<ManakaiDOM:DOMAttribute>) {
          my $getter = $method->{ExpandedURI q<dis2pm:getter>};
          my $setter = defined $method->{ExpandedURI q<dis2pm:setter>}->{Name}
                         ? $method->{ExpandedURI q<dis2pm:setter>} : undef;
          my $for = [keys %{$method->{For}}]->[0];
          unless (dis_uri_for_match (ExpandedURI q<ManakaiDOM:ManakaiDOM1>,
                                     $for, node => $method->{src})) {
            $for = ExpandedURI q<ManakaiDOM:ManakaiDOMLatest>;
          }
          my $get_code = dispm_get_code (resource => $getter);
          if (defined $get_code) {
            my $default = dispm_get_value
                           (resource => $getter,
                            ExpandedURI q<dis2pm:ValueKeyName>
                                => ExpandedURI q<d:DefaultValue>,
                            ExpandedURI q<dis2pm:useDefaultValue> => 1,
                            ExpandedURI q<dis2pm:valueType>
                              => $getter->{ExpandedURI q<d:actualType>});
            $get_code = perl_statement
                          (defined $default ? 'my $r = '.$default : 'my $r').
                        $get_code. "\n" .
                        perl_statement ('$r');
          } else { ## Get code not defined
            $get_code = perl_statement
                      dispm_perl_throws
                        class => ExpandedURI q<DOMCore:ManakaiDOMException>,
                        class_for => $for,
                        type => 'NOT_SUPPORTED_ERR',
                        subtype =>
                          ExpandedURI q<MDOMX:MDOM_IMPL_ATTR_NOT_IMPLEMENTED>,
                        xparam => {
                          ExpandedURI q<MDOMX:class>
                                 => $pack->{ExpandedURI q<dis2pm:packageName>},
                          ExpandedURI q<MDOMX:attr>
                                 => $method->{ExpandedURI q<dis2pm:methodName>},
                          ExpandedURI q<MDOMX:on> => 'get',
                        };
          }
          if ($setter) {
            my $set_code = dispm_get_code (resource => $setter);
            if (defined $set_code) {
              my $default = dispm_get_value
                           (resource => $setter,
                            ExpandedURI q<dis2pm:ValueKeyName>
                                => ExpandedURI q<d:DefaultValue>,
                            ExpandedURI q<dis2pm:useDefaultValue> => 1,
                            ExpandedURI q<dis2pm:valueType>
                              => $getter->{ExpandedURI q<d:actualType>});
              $set_code = perl_statement
                          (defined $default ? 'my $r = '.$default : 'my $r').
                          $set_code. "\n" .
                          perl_statement ('$r');
            } else { ## Set code not defined
              $set_code = perl_statement
                      dispm_perl_throws
                        class => ExpandedURI q<DOMCore:ManakaiDOMException>,
                        class_for => $for,
                        type => 'NOT_SUPPORTED_ERR',
                        subtype =>
                          ExpandedURI q<MDOMX:MDOM_IMPL_ATTR_NOT_IMPLEMENTED>,
                        xparam => {
                          ExpandedURI q<MDOMX:class>
                                 => $pack->{ExpandedURI q<dis2pm:packageName>},
                          ExpandedURI q<MDOMX:attr>
                                 => $method->{ExpandedURI q<dis2pm:methodName>},
                          ExpandedURI q<MDOMX:on> => 'set',
                      };
            }
            $get_code = perl_if '@_ == 2',
                                perl_statement ('my ($self, $given) = @_').
                                $set_code,
                                perl_statement ('my ($self) = @_').
                                $get_code;
          } else {
            $get_code = perl_statement ('my ($self) = @_').
                        $get_code;
          }
          $result .= perl_sub
                       (name => $method->{ExpandedURI q<dis2pm:methodName>},
                        prototype => $setter ? '$;$' : '$',
                        code => $get_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			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	wakaba	1.3	MDOMX => q<http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#>,
13	wakaba	1.1	owl => q<http://www.w3.org/2002/07/owl#>,
14			rdf => q<http://www.w3.org/1999/02/22-rdf-syntax-ns#>,
15			rdfs => q<http://www.w3.org/2000/01/rdf-schema#>,
16			};
17
18			use Getopt::Long;
19			use Pod::Usage;
20			use Storable;
21			my %Opt;
22			GetOptions (
23			'for=s' => \$Opt{For},
24			'help' => \$Opt{help},
25			'module-name=s' => \$Opt{module_name},
26			'module-uri=s' => \$Opt{module_uri},
27			'verbose!' => $Opt{verbose},
28			) or pod2usage (2);
29			pod2usage ({-exitval => 0, -verbose => 1}) if $Opt{help};
30			$Opt{file_name} = shift;
31			pod2usage ({-exitval => 2, -verbose => 0}) unless $Opt{file_name};
32			pod2usage (2) if not $Opt{module_uri} and not $Opt{module_name};
33
34			BEGIN {
35			require 'manakai/genlib.pl';
36			require 'manakai/dis.pl';
37			}
38			our $State = retrieve ($Opt{file_name})
39			or die "$0: $Opt{file_name}: Cannot load";
40			our $result = '';
41
42			eval q{
43			sub impl_msg ($;%) {
44			warn shift () . "\n";
45			}
46			} unless $Opt{verbose};
47
48			sub perl_change_package (%) {
49			my %opt = @_;
50			my $fn = $opt{full_name};
51			impl_err (qq<$fn: Bad package name>) unless $fn;
52			unless ($fn eq $State->{ExpandedURI q<dis2pm:currentPackage>}) {
53			$State->{ExpandedURI q<dis2pm:currentPackage>} = $fn;
54			return perl_statement qq<package $fn>;
55			} else {
56			return '';
57			}
58			} # perl_change_package
59
60	wakaba	1.3	=item $code = dispm_perl_throws (%opt)
61
62			Generates a code to throw an exception.
63
64			=cut
65
66			sub dispm_perl_throws (%) {
67			my %opt = @_;
68			my $x = $State->{Type}->{$opt{class}};
69			my $r = 'report ';
70			unless (defined $x->{Name}) {
71			$opt{class} = dis_typeforuris_to_uri ($opt{class}, $opt{class_for}, %opt);
72			$x = $State->{Type}->{$opt{class}};
73			}
74			valid_err (qq<Exception class <$opt{class}> is not defined>,
75			node => $opt{node}) unless defined $x->{Name};
76			if ($x->{ExpandedURI q<dis2pm:type>} and
77			{
78			ExpandedURI q<ManakaiDOM:ExceptionClass> => 1,
79			ExpandedURI q<ManakaiDOM:WarningClass> => 1,
80			}->{$x->{ExpandedURI q<dis2pm:type>}}) {
81			$r .= $x->{ExpandedURI q<dis2pm:packageName>} . ' ' .
82			perl_list -type => $opt{type},
83			-object => perl_code_literal ('$self'),
84			%{$opt{xparam} \|\| {}};
85			} else {
86			no warnings 'uninitialized';
87			valid_err (qq{Resource <$opt{class}> (<$x->{ExpandedURI q<dis2pm:type>}>) }.
88			q<is neither exception class nor >.
89			q<warning class>, node => $opt{node});
90			}
91			return $r;
92			} # dispm_perl_throw
93
94			{
95			use re 'eval';
96			my $RegBlockContent;
97			$RegBlockContent = qr/(?>[^{}\\])(?>(?>[^{}\\]+\|\\.\|\{(??{$RegBlockContent})\}))/s;
98			## Defined by genlib.pl but overridden.
99			sub perl_code ($;%) {
100			my ($s, %opt) = @_;
101			valid_err q<Uninitialized value in perl_code>,
102			node => $opt{node} unless defined $s;
103			local $State->{Namespace}
104			= $State->{Module}->{$opt{resource}->{parentModule}}->{nsBinding};
105			$s =~ s[<Q:([^<>]+)>\|\b(null\|true\|false)\b][
106			my ($q, $l) = ($1, $2);
107			if (defined $q) {
108			if ($q =~ /\}/) {
109			valid_warn qq<QName "$q" has a "}" - it might be a typo>;
110			}
111			perl_literal (dis_qname_to_uri ($q, %opt));
112			} else {
113			{true => 1, false => 0, null => 'undef'}->{$l};
114			}
115			]ge;
116			## TODO: Ensure Message::Util::Error imported if "try"ing.
117			## ISSUE: __FILE__ & __LINE__ will break if multiline substition happens.
118			$s =~ s{
119			\b__([A-Z]+)
120			(?:\{($RegBlockContent)\})?
121			__\b
122			}{
123			my ($name, $data) = ($1, $2);
124			my $r;
125			if ($name eq 'XCLASS' or ## Manakai DOM Class
126			$name eq 'XSUPER' or ## Manakai DOM Class (internal)
127			$name eq 'XIIF' or ## DOM Interface + Internal interface & prop
128			$name eq 'XIF') { ## DOM Interface
129			#local $Status->{condition} = $Status->{condition};
130			if ($data =~ s/::([^:]*)$//) {
131			#$Status->{condition} = $1;
132			}
133			#$r = perl_package_name {qw/CLASS name SUPER name IIF iif IF if/}->{$name}
134			# => $data,
135			# is_internal => {qw/SUPER 1/}->{$name},
136			#condition => $Status->{condition};
137			} elsif ($name eq 'XINT') { ## Internal Method / Attr Name
138			if (defined $data) {
139			if ($data =~ /^{($RegBlockContent)}$/o) {
140			$data = $1;
141			my $name = $1 if $data =~ s/^\s(\w+)\s(?:$\|:\s*)// or
142			valid_err qq<Syntax of preprocessing macro "INT" is invalid>,
143			node => $opt{node};
144			#local $Status->{preprocess_variable}
145			# = {%{$Status->{preprocess_variable}\|\|{}}};
146			while ($data =~ /\G(\S+)\s(?:=>\s(\S+)\s)?(?:,\s\|$)/g) {
147			my ($n, $v) = ($1, defined $2 ? $2 : 1);
148			for ($n, $v) {
149			s/^'([^']+)'$/$1/; ## ISSUE: Doesn't support quoted-'
150			}
151			#$Status->{preprocess_variable}->{$n} = $v;
152			}
153			valid_err q<Preprocessing macro INT{} cannot be used here>
154			unless $opt{internal};
155			$r = perl_comment ("INT: $name").
156			$opt{internal}->($name);
157			} elsif ($data =~ s/^SP://) {
158			$r = '___'.$data;
159			} else {
160			$r = perl_internal_name $data;
161			}
162			} else {
163			valid_err q<Preprocessing macro INT cannot be used here>
164			unless $opt{internal};
165			$r = $opt{internal}->();
166			}
167			} elsif ($name eq 'DEEP') { ## Deep Method Call
168			$r = 'do { local $Error::Depth = $Error::Depth + 1;' . perl_code ($data) .
169			'}';
170			} elsif ($name eq 'XEXCEPTION' or $name eq 'XWARNING') {
171			## Raising an Exception or Warning
172			if ($data =~ s/^\s(\w+)\s\.\s(\w+)\s(?:\.\s([\w:]+)\s)?(?:::\s*\|$)//) {
173			$r = perl_exception (level => $name,
174			class => $1,
175			type => $2,
176			subtype => $3,
177			param => perl_code $data);
178			} else {
179			valid_err qq<Exception type and name required: "$data">,
180			node => $opt{node};
181			}
182			} elsif ($name eq 'XCODE') { # Built-in code
183			my ($nm, %param);
184			if ($data =~ s/^(\w+)\s(?::\s\|$)//) {
185			$nm = $1;
186			} elsif ($data =~ s/^<([^<>]+)>\s(?::\s\|$)//) {
187			$nm = $1;
188			} else {
189			valid_err q<Built-in code name required>;
190			}
191			while ($data =~ /\G(\S+)\s=>\s(\S+)\s(?:,\s\|$)/g) {
192			$param{$1} = $2;
193			}
194			$r = perl_builtin_code ($nm, condition => $opt{condition}, %param);
195			} elsif ($name eq 'XPACKAGE' and $data) {
196			if ($data eq 'Global') {
197			#$r = $ManakaiDOMModulePrefix;
198			} else {
199			valid_err qq<PACKAGE "$data" not supported>;
200			}
201			} elsif ($name eq 'XREQUIRE') {
202			#$r = perl_statement (q<require >. perl_package_name name => $data);
203			} elsif ($name eq 'XWHEN') {
204			if ($data =~ s/^\sIS\s\{($RegBlockContent)\}::\s*//o) {
205			my $v = $1;
206			if ($v =~ /^\s'([^']+)'\s$/) { ## ISSUE: Doesn't support quoted-'
207			if ($State->{preprocess_variable}->{$1}) {
208			$r = perl_code ($data, %opt);
209			} else {
210			$r = perl_comment ($data);
211			}
212			} else {
213			valid_err qq<WHEN-IS condition "$v" is invalid>,
214			node => $opt{node};
215			}
216			} else {
217			valid_err qq<Syntax for preprocessing macro "WHEN" is invalid>,
218			node => $opt{node};
219			}
220			} elsif ($name eq 'FILE' or $name eq 'LINE' or $name eq 'PACKAGE') {
221			$r = qq<__${name}__>;
222			} else {
223			$r = $&;
224			#valid_err qq<Preprocessing macro "$name" not supported>;
225			}
226			$r;
227			}goex;
228			$s;
229			}
230			}
231
232			## Defined in genlib.pl but overridden.
233			sub perl_code_source ($%) {
234			my ($s, %opt) = @_;
235			my $npk = [qw/Name QName Label/];
236			my $f1 = sprintf q<File <%s> Node <%s> [Chunk #%d]>,
237			$opt{file} \|\| $State->{Module}->{$opt{resource}->{parentModule}}->{FileName},
238			$opt{path} \|\| ($opt{resource}->{src}
239			? $opt{resource}->{src}->node_path (key => $npk)
240			: $opt{node} ? $opt{node}->node_path (key => $npk)
241			: 'x:unknown ()'),
242			++($State->{ExpandedURI q<dis2pm:generatedChunk>} \|\|= 0);
243			my $f2 = sprintf q<Module <%s> [Chunk #%d]>,
244			$opt{file} \|\| $State->{Module}->{$State->{module}}->{URI},
245			++($State->{ExpandedURI q<dis2pm:generatedChunk>} \|\|= 0);
246			$f1 =~ s/"/\"/g; $f2 =~ s/"/\"/g;
247			sprintf qq<\n#line %d "%s"\n%s\n#line 1 "%s"\n>,
248			$opt{line} \|\| 1, $f1, $s, $f2;
249			}
250
251
252
253
254			=item $code = dispm_get_code (resource => $res, %opt)
255
256			Generates a Perl code fragment from resource(s).
257
258			=cut
259
260			sub dispm_get_code (%) {
261			my %opt = @_;
262			my $key = $opt{ExpandedURI q<dis2pm:DefKeyName>} \|\| ExpandedURI q<d:Def>;
263			my $n = dis_get_attr_node (%opt, parent => $opt{resource}->{src},
264			name => {uri => $key},
265			ContentType => ExpandedURI q<lang:Perl>);
266			if ($n) {
267			return perl_code_source
268			perl_code ($n->value,
269			%opt, node => $n),
270			%opt,
271			node => $n;
272			}
273			return undef;
274			} # dispm_get_code
275
276			=item $code = dispm_get_value (%opt)
277
278			Gets value property and returns it as a Perl code fragment.
279
280			=cut
281
282			sub dispm_get_value (%) {
283			my %opt = @_;
284			my $key = $opt{ExpandedURI q<dis2pm:DefKeyName>} \|\| ExpandedURI q<d:Value>;
285			my $vt = $opt{ExpandedURI q<dis2pm:valueType>} \|\| ExpandedURI q<DOMMain:any>;
286			my $n = dis_get_elements_nodes (%opt, parent => $opt{resource}->{src},
287			name => {uri => $key});
288			for my $n (@$n) {
289			my $t = dis_get_attr_node (%opt, parent => $n, name => 'ContentType');
290			my $type;
291			if ($t) {
292			$type = dis_qname_to_uri ($t->value, %opt, node => $t);
293			} else {
294			$type = ExpandedURI q<DOMMain:any>; ## ISSUE: Is this appropriate type?
295			}
296			valid_err (qq<Type <$type> is not defined>, node => $t \|\| $n)
297			unless defined $State->{Type}->{$type}->{Name};
298
299			if (dis_uri_ctype_match (ExpandedURI q<lang:Perl>, $type, %opt)) {
300			## ISSUE: Is some pre-process required?
301			return $n->value;
302			}
303			}
304
305			## No explicit value specified
306			if ($opt{ExpandedURI q<dis2pm:useDefaultValue>}) {
307			if (dis_uri_ctype_match (ExpandedURI q<DOMMain:DOMString>, $vt, %opt)) {
308			return q<"">;
309			}
310			}
311			return undef;
312			} # dispm_get_value
313
314
315	wakaba	1.1	## Outputed module and "For"
316			my $mf = dis_get_module_uri (module_name => $Opt{module_name},
317			module_uri => $Opt{module_uri},
318			For => $Opt{For});
319			$State->{DefaultFor} = $mf->{For};
320			$State->{module} = $mf->{module};
321
322	wakaba	1.3	valid_err
323			(qq{Perl module <$State->{module}> not defined for <$State->{DefaultFor}>},
324			node => $State->{Module}->{$State->{module}}->{src})
325			unless $State->{Module}->{$State->{module}}
326			->{ExpandedURI q<dis2pm:packageName>};
327
328	wakaba	1.1	$State->{ExpandedURI q<dis2pm:currentPackage>} = 'main';
329			$result .= "#!/usr/bin/perl \n";
330			$result .= perl_comment q<This file is automatically generated from> . "\n" .
331			q<"> . $Opt{file_name} . q<" at > .
332			rfc3339_date (time) . qq<.\n> .
333			q<Don't edit by hand!>;
334			$result .= perl_comment qq{Module <$State->{module}>};
335			$result .= perl_comment qq{For <$State->{DefaultFor}>};
336			$result .= perl_statement q<use strict>;
337			$result .= perl_change_package
338			(full_name => $State->{Module}->{$State->{module}}
339			->{ExpandedURI q<dis2pm:packageName>});
340			$result .= perl_statement
341			perl_assign
342			perl_var (type => '$', local_name => 'VERSION',
343			scope => 'our')
344			=> perl_literal version_date time;
345
346			for my $pack (values %{$State->{Module}->{$State->{module}}
347			->{ExpandedURI q<dis2pm:package>}\|\|{}}) {
348			next unless defined $pack->{Name};
349			if ({
350			ExpandedURI q<ManakaiDOM:Class> => 1,
351			ExpandedURI q<ManakaiDOM:IF> => 1,
352			ExpandedURI q<ManakaiDOM:ExceptionClass> => 1,
353			ExpandedURI q<ManakaiDOM:ExceptionIF> => 1,
354			ExpandedURI q<ManakaiDOM:WarningIF> => 1,
355			}->{$pack->{ExpandedURI q<dis2pm:type>}}) {
356			## Package name and version
357			$result .= perl_change_package
358			(full_name => $pack->{ExpandedURI q<dis2pm:packageName>});
359			$result .= perl_statement
360			perl_assign
361			perl_var (type => '$', local_name => 'VERSION',
362			scope => 'our')
363			=> perl_literal version_date time;
364			## Inheritance
365	wakaba	1.2	my $isa = [];
366	wakaba	1.1	for my $uri (@{$pack->{ISA}\|\|[]}, @{$pack->{Implement}\|\|[]}) {
367			my $pack = $State->{Type}->{$uri};
368			if (defined $pack->{ExpandedURI q<dis2pm:packageName>}) {
369	wakaba	1.2	push @$isa, $pack->{ExpandedURI q<dis2pm:packageName>};
370	wakaba	1.1	} else {
371			impl_msg ("Inheriting package name for <$uri> not defined",
372			node => $pack->{src}) if $Opt{verbose};
373			}
374			}
375	wakaba	1.2	$isa = array_uniq $isa;
376			$result .= perl_inherit $isa;
377			$result .= '$' . $_ . "::;\n" for @$isa;
378	wakaba	1.1	## Members
379			if ({
380			ExpandedURI q<ManakaiDOM:Class> => 1,
381			ExpandedURI q<ManakaiDOM:ExceptionClass> => 1,
382			ExpandedURI q<ManakaiDOM:WarningClass> => 1,
383			}->{$pack->{ExpandedURI q<dis2pm:type>}}) {
384			for my $method (values %{$pack->{ExpandedURI q<dis2pm:method>}}) {
385			next unless defined $method->{Name};
386			if ($method->{ExpandedURI q<dis2pm:type>} eq
387			ExpandedURI q<ManakaiDOM:DOMMethod>) {
388	wakaba	1.3	my $proto = '$';
389			my @param = ('self');
390			my $param_opt = 0;
391			for my $param (@{$method->{ExpandedURI q<dis2pm:param>}\|\|[]}) {
392			if ($param->{ExpandedURI q<dis2pm:nullable>}) {
393			$proto .= ';' unless $param_opt;
394			$param_opt++;
395			}
396			$proto .= '$';
397			push @param, $param->{ExpandedURI q<dis2pm:paramName>};
398			}
399			my $code = dispm_get_code
400			(resource => $method->{ExpandedURI q<dis2pm:return>});
401			if (defined $code) {
402			my $my = perl_statement ('my ('.join (", ", map {"\$$_"} @param).
403			') = @_');
404			my $return = defined $method->{ExpandedURI q<dis2pm:return>}->{Name}
405			? $method->{ExpandedURI q<dis2pm:return>} : undef;
406			if ($return->{ExpandedURI q<d:actualType>} ? 1 : 0) {
407			my $default = dispm_get_value
408			(resource => $return,
409			ExpandedURI q<dis2pm:ValueKeyName>
410			=> ExpandedURI q<d:DefaultValue>,
411			ExpandedURI q<dis2pm:useDefaultValue> => 1,
412			ExpandedURI q<dis2pm:valueType>
413			=> $return->{ExpandedURI q<d:actualType>});
414			$code = $my .
415			perl_statement
416			(defined $default ? 'my $r = '.$default : 'my $r').
417			$code . "\n" .
418			perl_statement ('$r');
419			} else {
420			$code = $my . $code;
421			}
422			} else { ## Code not defined
423			my $for = [keys %{$method->{For}}]->[0];
424			unless (dis_uri_for_match (ExpandedURI q<ManakaiDOM:ManakaiDOM1>,
425			$for, node => $method->{src})) {
426			$for = ExpandedURI q<ManakaiDOM:ManakaiDOMLatest>;
427			}
428			$code = perl_statement
429			dispm_perl_throws
430			class => ExpandedURI q<DOMCore:ManakaiDOMException>,
431			class_for => $for,
432			type => 'NOT_SUPPORTED_ERR',
433			subtype =>
434			ExpandedURI q<MDOMX:MDOM_IMPL_METHOD_NOT_IMPLEMENTED>,
435			xparam => {
436			ExpandedURI q<MDOMX:class>
437			=> $pack->{ExpandedURI q<dis2pm:packageName>},
438			ExpandedURI q<MDOMX:method>
439			=> $method->{ExpandedURI q<dis2pm:methodName>},
440			};
441			}
442	wakaba	1.1	$result .= perl_sub
443			(name => $method->{ExpandedURI q<dis2pm:methodName>},
444	wakaba	1.3	code => $code, prototype => $proto);
445	wakaba	1.1	} elsif ($method->{ExpandedURI q<dis2pm:type>} eq
446			ExpandedURI q<ManakaiDOM:DOMAttribute>) {
447	wakaba	1.3	my $getter = $method->{ExpandedURI q<dis2pm:getter>};
448			my $setter = defined $method->{ExpandedURI q<dis2pm:setter>}->{Name}
449			? $method->{ExpandedURI q<dis2pm:setter>} : undef;
450			my $for = [keys %{$method->{For}}]->[0];
451			unless (dis_uri_for_match (ExpandedURI q<ManakaiDOM:ManakaiDOM1>,
452			$for, node => $method->{src})) {
453			$for = ExpandedURI q<ManakaiDOM:ManakaiDOMLatest>;
454			}
455			my $get_code = dispm_get_code (resource => $getter);
456			if (defined $get_code) {
457			my $default = dispm_get_value
458			(resource => $getter,
459			ExpandedURI q<dis2pm:ValueKeyName>
460			=> ExpandedURI q<d:DefaultValue>,
461			ExpandedURI q<dis2pm:useDefaultValue> => 1,
462			ExpandedURI q<dis2pm:valueType>
463			=> $getter->{ExpandedURI q<d:actualType>});
464			$get_code = perl_statement
465			(defined $default ? 'my $r = '.$default : 'my $r').
466			$get_code. "\n" .
467			perl_statement ('$r');
468			} else { ## Get code not defined
469			$get_code = perl_statement
470			dispm_perl_throws
471			class => ExpandedURI q<DOMCore:ManakaiDOMException>,
472			class_for => $for,
473			type => 'NOT_SUPPORTED_ERR',
474			subtype =>
475			ExpandedURI q<MDOMX:MDOM_IMPL_ATTR_NOT_IMPLEMENTED>,
476			xparam => {
477			ExpandedURI q<MDOMX:class>
478			=> $pack->{ExpandedURI q<dis2pm:packageName>},
479			ExpandedURI q<MDOMX:attr>
480			=> $method->{ExpandedURI q<dis2pm:methodName>},
481			ExpandedURI q<MDOMX:on> => 'get',
482			};
483			}
484			if ($setter) {
485			my $set_code = dispm_get_code (resource => $setter);
486			if (defined $set_code) {
487			my $default = dispm_get_value
488			(resource => $setter,
489			ExpandedURI q<dis2pm:ValueKeyName>
490			=> ExpandedURI q<d:DefaultValue>,
491			ExpandedURI q<dis2pm:useDefaultValue> => 1,
492			ExpandedURI q<dis2pm:valueType>
493			=> $getter->{ExpandedURI q<d:actualType>});
494			$set_code = perl_statement
495			(defined $default ? 'my $r = '.$default : 'my $r').
496			$set_code. "\n" .
497			perl_statement ('$r');
498			} else { ## Set code not defined
499			$set_code = perl_statement
500			dispm_perl_throws
501			class => ExpandedURI q<DOMCore:ManakaiDOMException>,
502			class_for => $for,
503			type => 'NOT_SUPPORTED_ERR',
504			subtype =>
505			ExpandedURI q<MDOMX:MDOM_IMPL_ATTR_NOT_IMPLEMENTED>,
506			xparam => {
507			ExpandedURI q<MDOMX:class>
508			=> $pack->{ExpandedURI q<dis2pm:packageName>},
509			ExpandedURI q<MDOMX:attr>
510			=> $method->{ExpandedURI q<dis2pm:methodName>},
511			ExpandedURI q<MDOMX:on> => 'set',
512			};
513			}
514			$get_code = perl_if '@_ == 2',
515			perl_statement ('my ($self, $given) = @_').
516			$set_code,
517			perl_statement ('my ($self) = @_').
518			$get_code;
519			} else {
520			$get_code = perl_statement ('my ($self) = @_').
521			$get_code;
522			}
523	wakaba	1.1	$result .= perl_sub
524			(name => $method->{ExpandedURI q<dis2pm:methodName>},
525	wakaba	1.3	prototype => $setter ? '$;$' : '$',
526			code => $get_code);
527	wakaba	1.1	}
528			} # package method
529			## TODO: Const
530			}
531			## TODO: Const
532			} # root object
533			}
534
535			## Export
536			if (keys %{$State->{perl_primary_module}->{perl_export_ok}\|\|{}}) {
537			$result .= perl_change_package
538			full_name => $State->{perl_primary_module}->{perl_package_name};
539			$result .= perl_statement 'require Exporter';
540			$result .= perl_inherit ['Exporter'];
541			$result .= perl_statement
542			perl_assign
543			perl_var (type => '@', scope => 'our',
544			local_name => 'EXPORT_OK')
545			=> '(' . perl_list (keys %{$State->{perl_primary_module}
546			->{perl_export_ok}}) . ')';
547			if (keys %{$State->{perl_primary_module}->{perl_export_tags}\|\|{}}) {
548			$result .= perl_statement
549			perl_assign
550			perl_var (type => '%', scope => 'our',
551			local_name => 'EXPORT_TAGS')
552			=> '(' . perl_list (map {
553			$_ => [keys %{$State->{perl_primary_module}
554			->{perl_export_tags}->{$_}}]
555			} keys %{$State->{perl_primary_module}
556			->{perl_export_tags}}) . ')';
557			}
558			}
559
560			$result .= perl_statement 1;
561
562			output_result $result;
563
564			1;