manakai/bin/mkdisdump.pl

use lib qw[../..];

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

=head1 NAME

cdis2pm - Generating Perl Module from a Compiled "dis"

=head1 SYNOPSIS

  perl path/to/cdis2pm.pl input.cdis \
            {--module-name=ModuleName | --module-uri=module-uri} \
            [--for=for-uri] [options] > ModuleName.pm
  perl path/to/cdis2pm.pl --help

=head1 DESCRIPTION

The C<cdis2pm> script generates a Perl module from a compiled "dis"
("cdis") file.  It is intended to be used to generate a manakai 
DOM Perl module files, although it might be useful for other purpose. 

This script is part of manakai. 

=cut

use Message::DOM::DOMHTML;
use Message::DOM::DOMLS;
use Message::Util::DIS::DISDump;
use Message::Util::QName::Filter {
  ddoct => q<http://suika.fam.cx/~wakaba/archive/2005/8/disdump-xslt#>,
  DIS => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/DIS#>,
  dis => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/lang#dis-->,
  dis2pm => q<http://suika.fam.cx/~wakaba/archive/2004/11/8/dis2pm#>,
  DISCore => q<http://suika.fam.cx/~wakaba/archive/2004/dis/Core#>,
  DISLang => q<http://suika.fam.cx/~wakaba/archive/2004/dis/Lang#>,
  DISPerl => q<http://suika.fam.cx/~wakaba/archive/2004/dis/Perl#>,
  disPerl => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/lang#dis--Perl-->,
  DOMCore => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/dom-core#>,
  DOMEvents => q<http://suika.fam.cx/~wakaba/archive/2004/dom/events#>,
  DOMLS => q<http://suika.fam.cx/~wakaba/archive/2004/dom/ls#>,
  DOMMain => q<http://suika.fam.cx/~wakaba/archive/2004/dom/main#>,
  DOMXML => q<http://suika.fam.cx/~wakaba/archive/2004/dom/xml#>,
  dump => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/DIS#DISDump/>,
  DX => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/Error/DOMException#>,
  html5 => q<http://www.w3.org/1999/xhtml>,
  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#>,
  Markup => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Markup#>,
  MDOMX => q<http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#>,
  owl => q<http://www.w3.org/2002/07/owl#>,
  pc => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/PerlCode#>,
  rdf => q<http://www.w3.org/1999/02/22-rdf-syntax-ns#>,
  rdfs => q<http://www.w3.org/2000/01/rdf-schema#>,
  swcfg21 => q<http://suika.fam.cx/~wakaba/archive/2005/swcfg21#>,
  TreeCore => q<>,
  Util => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/>,
  xhtml1 => q<http://www.w3.org/1999/xhtml>,
  xhtml2 => q<http://www.w3.org/2002/06/xhtml2>,
  xml => q<http://www.w3.org/XML/1998/namespace>,
};

=head1 OPTIONS

=over 4

=item --enable-assertion / --noenable-assertion (default)

Whether assertion codes should be outputed or not. 

=item --for=I<for-uri> (Optional)

Specifies the "For" URI reference for which the outputed module is. 
If this parameter is ommitted, the default "For" URI reference 
for the module, if any, or the C<ManakaiDOM:all> is assumed. 

=item --help

Shows the help message. 

=item --module-name=I<ModuleName>

The name of module to output.  It is the local name part of 
the C<Module> C<QName> in the source "dis" file.  Either 
C<--module-name> or C<--module-uri> is required. 

=item --module-uri=I<module-uri>

A URI reference that identifies a module to output.  Either 
C<--module-name> or C<--module-uri> is required. 

=item --output-file-path=I<perl-module-file-path> (default: C<STDOUT>)

A platform-dependent file name path for the output.
If it is not specified, then the generated Perl module
content is outputed to the standard output.

=item --output-module-version (default) / --nooutput-module-version

Whether the C<$VERSION> special variable should be generated or not. 

=item --verbose / --noverbose (default)

Whether a verbose message mode should be selected or not. 

=back

=cut

use Getopt::Long;
use Pod::Usage;
use Storable;
use Message::Util::Error;
my %Opt;
GetOptions (
  'for=s' => \$Opt{For},
  'help' => \$Opt{help},
  'module-uri=s' => \$Opt{module_uri},
  'output-file-path=s' => \$Opt{output_file_name},
) 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) unless $Opt{module_uri};

sub status_msg ($) {
  my $s = shift;
  $s .= "\n" unless $s =~ /\n$/;
  print STDERR $s;
}

sub status_msg_ ($) {
  my $s = shift;
  print STDERR $s;
}

sub verbose_msg ($) {
  my $s = shift;
  $s .= "\n" unless $s =~ /\n$/;
  print STDERR $s;
}

sub verbose_msg_ ($) {
  my $s = shift;
  print STDERR $s;
}

my $impl = $Message::DOM::DOMImplementationRegistry->get_dom_implementation
               ({
                 ExpandedURI q<ManakaiDOM:Minimum> => '3.0',
#                 ExpandedURI q<ManakaiDOM:HTML> => '', # 3.0
                 '+' . ExpandedURI q<DOMLS:LS> => '3.0',
                 '+' . ExpandedURI q<DIS:Doc> => '2.0',
                 ExpandedURI q<DIS:Dump> => '1.0',
                });

## -- Load input dac database file
  status_msg_ qq<Opening dac file "$Opt{file_name}"...>;
  my $db = $impl->get_feature (ExpandedURI q<DIS:Core> => '1.0')
                ->pl_load_dis_database ($Opt{file_name});
  status_msg qq<done\n>;

## -- Load requested module
  my $mod = $db->get_module ($Opt{module_uri}, for_arg => $Opt{For});
  unless ($Opt{For}) {
    my $el = $mod->source_element;
    if ($el) {
      $Opt{For} = $el->default_for_uri;
      $mod = $db->get_module ($Opt{module_uri}, for_arg => $Opt{For});
    }
  }
  unless ($mod->is_defined) {
    die qq<$0: Module <$Opt{module_uri}> for <$Opt{For}> is not defined>;
  }

  status_msg qq<Module <$Opt{module_uri}> for <$Opt{For}>...>;

sub append_module_documentation (%) {
  my %opt = @_;
  my $section = $opt{result_parent}->create_module ($opt{source_resource}->uri);

  my $pl_full_name = $opt{source_resource}->pl_fully_qualified_name;
  if (defined $pl_full_name) {
    $section->perl_package_name ($pl_full_name);
    my $path = $pl_full_name;
    $path =~ s#::#/#g;
    $section->resource_file_path_stem ($path);
    $section->set_attribute_ns
      (ExpandedURI q<ddoct:>, 'ddoct:basePath', '../' x ($path =~ tr#/#/#));
  }

  $section->resource_file_name_stem ($opt{source_resource}->pl_file_name_stem);

  append_description (source_resource => $opt{source_resource},
                      result_parent => $section);

  for my $rres (@{$opt{source_resource}->get_property_resource_list
                           (ExpandedURI q<DIS:resource>)}) {
    if ($rres->owner_module eq $opt{source_resource}) { ## Defined in this module
                          ## TODO: Modification required to support modplans
      print STDERR "*";
      if ($rres->is_type_uri (ExpandedURI q<ManakaiDOM:Class>)) {
        append_class_documentation
          (result_parent => $section,
           source_resource => $rres);
      } elsif ($rres->is_type_uri (ExpandedURI q<ManakaiDOM:IF>)) {
        append_interface_documentation
          (result_parent => $section,
           source_resource => $rres);
      }
    } else {  ## Aliases
      # 
    }
  }
  print STDERR "\n";
} # append_module_documentation

sub append_interface_documentation (%) {
  my %opt = @_;
  my $section = $opt{result_parent}->create_interface
                                        ($opt{source_resource}->uri);

  my $pl_full_name = $opt{source_resource}->pl_fully_qualified_name;
  if (defined $pl_full_name) {
    $section->perl_package_name ($pl_full_name);
    my $path = $pl_full_name;
    $path =~ s#::#/#g;
    $section->resource_file_path_stem ($path);
    $section->set_attribute_ns
      (ExpandedURI q<ddoct:>, 'ddoct:basePath',
       join '', '../' x ($path =~ tr#/#/#));
  }

  $section->resource_file_name_stem ($opt{source_resource}->pl_file_name_stem);

  $section->is_exception_interface (1)
    if $opt{source_resource}->is_type_uri
                                 (ExpandedURI q<ManakaiDOM:ExceptionIF>);

  append_description (source_resource => $opt{source_resource},
                      result_parent => $section);

  ## Inheritance
  append_inheritance (source_resource => $opt{source_resource},
                      result_parent => $section);

  for my $memres (@{$opt{source_resource}->get_property_resource_list
                              (ExpandedURI q<DIS:childResource>)}) {
    if ($memres->is_type_uri (ExpandedURI q<DISLang:Method>)) {
      append_method_documentation (source_resource => $memres,
                                   result_parent => $section);
    } elsif ($memres->is_type_uri (ExpandedURI q<DISLang:Attribute>)) {
      append_attr_documentation (source_resource => $memres,
                                 result_parent => $section);
    } elsif ($memres->is_type_uri (ExpandedURI q<ManakaiDOM:ConstGroup>)) {

    }
  }
} # append_interface_documentation

sub append_class_documentation (%) {
  my %opt = @_;
  my $section = $opt{result_parent}->create_class ($opt{source_resource}->uri);

  my $pl_full_name = $opt{source_resource}->pl_fully_qualified_name;
  if (defined $pl_full_name) {
    $section->perl_package_name ($pl_full_name);
    my $path = $pl_full_name;
    $path =~ s#::#/#g;
    $section->resource_file_path_stem ($path);
    $section->set_attribute_ns
      (ExpandedURI q<ddoct:>, 'ddoct:basePath', '../' x ($path =~ tr#/#/#));
  }

  $section->resource_file_name_stem ($opt{source_resource}->pl_file_name_stem);

  append_description (source_resource => $opt{source_resource},
                      result_parent => $section);

  ## Inheritance
  append_inheritance (source_resource => $opt{source_resource},
                      result_parent => $section,
                      append_implements => 1);

  for my $memres (@{$opt{source_resource}->get_property_resource_list
                              (ExpandedURI q<DIS:childResource>)}) {
    if ($memres->is_type_uri (ExpandedURI q<DISLang:Method>)) {
      append_method_documentation (source_resource => $memres,
                                   result_parent => $section);
    } elsif ($memres->is_type_uri (ExpandedURI q<DISLang:Attribute>)) {
      append_attr_documentation (source_resource => $memres,
                                 result_parent => $section);
    } elsif ($memres->is_type_uri (ExpandedURI q<ManakaiDOM:Const>)) {

    } elsif ($memres->is_type_uri (ExpandedURI q<ManakaiDOM:ConstGroup>)) {

    }
  }
} # append_class_documentation

sub append_method_documentation (%) {
  my %opt = @_;
  my $perl_name = $opt{source_resource}->pl_name;
  my $m;
  if (defined $perl_name) {
    $m = $opt{result_parent}->create_method ($perl_name);
    
  } else {  ## Anonymous
    ## TODO
    return;
  }

  $m->add_uri ($opt{source_resource}->uri);
  
  append_description (source_resource => $opt{source_resource},
                      result_parent => $m);

  my $ret = $opt{source_resource}->get_child_resource_by_type
    (ExpandedURI q<DISLang:MethodReturn>);
  if ($ret) {
    my $r = $m->dis_return;

    try {
      $r->resource_data_type ($ret->dis_data_type_resource->uri);
      $r->resource_actual_data_type ($ret->dis_actual_data_type_resource->uri);
      
      append_description (source_resource => $ret,
                          result_parent => $r,
                          has_case => 1);

    ## TODO: Exceptions
    } catch Message::Util::DIS::ManakaiDISException with {
      
    };
  }

  for my $cr (@{$opt{source_resource}->get_property_resource_list
                  (ExpandedURI q<DIS:childResource>)}) {
    if ($cr->is_type_uri (ExpandedURI q<DISLang:MethodParameter>)) {
      append_param_documentation (source_resource => $cr,
                                  result_parent => $m);
    }
  }

  ## TODO: raises

  $m->resource_access ('private')
    if $opt{source_resource}->get_property_boolean
      (ExpandedURI q<ManakaiDOM:isForInternal>, 0);
} # append_method_documentation

sub append_attr_documentation (%) {
  my %opt = @_;
  my $perl_name = $opt{source_resource}->pl_name;
  my $m;
  if (defined $perl_name) {
    $m = $opt{result_parent}->create_attribute ($perl_name);
    
  } else {  ## Anonymous
    ## TODO
    return;
  }

  $m->add_uri ($opt{source_resource}->uri);
  
  append_description (source_resource => $opt{source_resource},
                      result_parent => $m,
                      has_case => 1);

  my $ret = $opt{source_resource}->get_child_resource_by_type
    (ExpandedURI q<DISLang:AttributeGet>);
  if ($ret) {
    my $r = $m->dis_get;

    $r->resource_data_type ($ret->dis_data_type_resource->uri);
    $r->resource_actual_data_type ($ret->dis_actual_data_type_resource->uri);
    
    append_description (source_resource => $ret,
                        result_parent => $r,
                        has_case => 1);

    ## TODO: Exceptions
  }

  my $set = $opt{source_resource}->get_child_resource_by_type
    (ExpandedURI q<DISLang:AttributeSet>);
  if ($set) {
    my $r = $m->dis_set;

    $r->resource_data_type ($set->dis_data_type_resource->uri);
    $r->resource_actual_data_type ($set->dis_actual_data_type_resource->uri);
    
    append_description (source_resource => $set,
                        result_parent => $r,
                        has_case => 1);

    ## TODO: InCase, Exceptions
  } else {
    $m->is_read_only_attribute (1);
  }

  $m->resource_access ('private')
    if $opt{source_resource}->get_property_boolean
      (ExpandedURI q<ManakaiDOM:isForInternal>, 0);
} # append_attr_documentation

sub append_param_documentation (%) {
  my %opt = @_;
  
  my $is_named_param = $opt{source_resource}->get_property_boolean
    (ExpandedURI q<DISPerl:isNamedParameter>, 0);

  my $perl_name = $is_named_param
    ? $opt{source_resource}->pl_name
    : $opt{source_resource}->pl_variable_name;
  
  my $p = $opt{result_parent}->create_parameter ($perl_name, $is_named_param);
  
  $p->is_nullable_parameter ($opt{source_resource}->pl_is_nullable);
  $p->resource_data_type ($opt{source_resource}->dis_data_type_resource->uri);
  $p->resource_actual_data_type
    ($opt{source_resource}->dis_actual_data_type_resource->uri);

  append_description (source_resource => $opt{source_resource},
                      result_parent => $p,
                      has_case => 1);
} # append_param_documentation

sub append_description (%) {
  my %opt = @_;
  my $od = $opt{result_parent}->owner_document;
  my $resd = $opt{source_resource}->get_feature (ExpandedURI q<DIS:Doc>, '2.0');
  my $doc = $resd->get_description ($od);
  $opt{result_parent}->create_description->append_child ($doc);
  ## TODO: Negotiation

  if ($opt{has_case}) {
    for my $caser (@{$opt{source_resource}->get_property_resource_list
                      (ExpandedURI q<DIS:childResource>)}) {
      if ($caser->is_type_uri (ExpandedURI q<ManakaiDOM:InCase>)) {
        my $case = $opt{result_parent}->append_case;
        my $cased = $caser->get_feature (ExpandedURI q<DIS:Doc>, '2.0');
        my $label = $cased->get_label ($od);
        if ($label) {
          $case->create_label->append_child ($label);
        }
        my $value = $caser->pl_code_fragment;
        if ($value) {
          $case->create_value->text_content ($value->stringify);
        }
        append_description (source_resource => $caser,
                            result_parent => $case);
      }
    }
  }
} # append_description

sub append_inheritance (%) {
  my %opt = @_;
  if (($opt{depth} ||= 0) == 100) {
    warn "<".$opt{source_resource}->uri.">: Loop in inheritance";
    return;
  }
  
  for my $isa (@{$opt{source_resource}->get_property_resource_list
                   (ExpandedURI q<dis:ISA>,
                    default_media_type => ExpandedURI q<dis:TFQNames>)}) {
    append_inheritance
      (source_resource => $isa,
       result_parent => $opt{result_parent}->append_new_extends ($isa->uri),
       depth => $opt{depth} + 1);
  }

  if ($opt{append_implements}) {
    for my $impl (@{$opt{source_resource}->get_property_resource_list
                      (ExpandedURI q<dis:Implement>,
                       default_media_type => ExpandedURI q<dis:TFQNames>,
                       recursive_isa => 1)}) {
      append_inheritance
        (source_resource => $impl,
         result_parent => $opt{result_parent}->append_new_implements
                                                  ($impl->uri),
         depth => $opt{depth});
    }
  }
} # append_inheritance

my $doc = $impl->create_disdump_document;

my $body = $doc->document_element;

append_module_documentation
  (result_parent => $body,
   source_resource => $mod);

my $lsimpl = $impl->get_feature (ExpandedURI q<DOMLS:LS> => '3.0');

status_msg_ qq<Writing file ""...>;

use Encode;
my $serializer = $lsimpl->create_mls_serializer
                        ({ExpandedURI q<DOMLS:SerializeDocumentInstance> => ''});
print Encode::encode ('utf8', $serializer->write_to_string ($doc));

status_msg qq<done>;

verbose_msg_ qq<Checking undefined resources...>;

$db->check_undefined_resource;

verbose_msg qq<done>;

verbose_msg_ qq<Closing database...>;
undef $db;
verbose_msg qq<done>;

=head1 SEE ALSO

L<lib/manakai/dis.pl> and L<bin/cdis2pm.pl> - Old version of 
this script.

L<lib/Message/Util/DIS.dis> - The <QUOTE::dis> object implementation.

L<lib/Message/Util/PerlCode.dis> - The Perl code generator.

L<lib/manakai/DISCore.dis> - The definition for the "dis" format. 

L<lib/manakai/DISPerl.dis> - The definition for the "dis" Perl-specific 
vocabulary. 

=head1 LICENSE

Copyright 2004-2005 Wakaba <w@suika.fam.cx>.  All rights reserved.

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut

1; # $Date: 2005/05/07 13:56:36 $
1	wakaba	1.1	use lib qw[../..];
2
3			#!/usr/bin/perl -w
4			use strict;
5
6			=head1 NAME
7
8			cdis2pm - Generating Perl Module from a Compiled "dis"
9
10			=head1 SYNOPSIS
11
12			perl path/to/cdis2pm.pl input.cdis \
13			{--module-name=ModuleName \| --module-uri=module-uri} \
14			[--for=for-uri] [options] > ModuleName.pm
15			perl path/to/cdis2pm.pl --help
16
17			=head1 DESCRIPTION
18
19			The C<cdis2pm> script generates a Perl module from a compiled "dis"
20			("cdis") file. It is intended to be used to generate a manakai
21			DOM Perl module files, although it might be useful for other purpose.
22
23			This script is part of manakai.
24
25			=cut
26
27			use Message::DOM::DOMHTML;
28			use Message::DOM::DOMLS;
29			use Message::Util::DIS::DISDump;
30			use Message::Util::QName::Filter {
31			ddoct => q<http://suika.fam.cx/~wakaba/archive/2005/8/disdump-xslt#>,
32			DIS => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/DIS#>,
33			dis => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/lang#dis-->,
34			dis2pm => q<http://suika.fam.cx/~wakaba/archive/2004/11/8/dis2pm#>,
35			DISCore => q<http://suika.fam.cx/~wakaba/archive/2004/dis/Core#>,
36			DISLang => q<http://suika.fam.cx/~wakaba/archive/2004/dis/Lang#>,
37			DISPerl => q<http://suika.fam.cx/~wakaba/archive/2004/dis/Perl#>,
38			disPerl => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/lang#dis--Perl-->,
39			DOMCore => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/dom-core#>,
40			DOMEvents => q<http://suika.fam.cx/~wakaba/archive/2004/dom/events#>,
41			DOMLS => q<http://suika.fam.cx/~wakaba/archive/2004/dom/ls#>,
42			DOMMain => q<http://suika.fam.cx/~wakaba/archive/2004/dom/main#>,
43			DOMXML => q<http://suika.fam.cx/~wakaba/archive/2004/dom/xml#>,
44			dump => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/DIS#DISDump/>,
45			DX => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/Error/DOMException#>,
46			html5 => q<http://www.w3.org/1999/xhtml>,
47			lang => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/lang#>,
48			Perl => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/lang#Perl-->,
49			license => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/license#>,
50			ManakaiDOM => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/manakai-dom#>,
51			Markup => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Markup#>,
52			MDOMX => q<http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#>,
53			owl => q<http://www.w3.org/2002/07/owl#>,
54			pc => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/PerlCode#>,
55			rdf => q<http://www.w3.org/1999/02/22-rdf-syntax-ns#>,
56			rdfs => q<http://www.w3.org/2000/01/rdf-schema#>,
57			swcfg21 => q<http://suika.fam.cx/~wakaba/archive/2005/swcfg21#>,
58			TreeCore => q<>,
59			Util => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/>,
60			xhtml1 => q<http://www.w3.org/1999/xhtml>,
61			xhtml2 => q<http://www.w3.org/2002/06/xhtml2>,
62			xml => q<http://www.w3.org/XML/1998/namespace>,
63			};
64
65			=head1 OPTIONS
66
67			=over 4
68
69			=item --enable-assertion / --noenable-assertion (default)
70
71			Whether assertion codes should be outputed or not.
72
73			=item --for=I<for-uri> (Optional)
74
75			Specifies the "For" URI reference for which the outputed module is.
76			If this parameter is ommitted, the default "For" URI reference
77			for the module, if any, or the C<ManakaiDOM:all> is assumed.
78
79			=item --help
80
81			Shows the help message.
82
83			=item --module-name=I<ModuleName>
84
85			The name of module to output. It is the local name part of
86			the C<Module> C<QName> in the source "dis" file. Either
87			C<--module-name> or C<--module-uri> is required.
88
89			=item --module-uri=I<module-uri>
90
91			A URI reference that identifies a module to output. Either
92			C<--module-name> or C<--module-uri> is required.
93
94			=item --output-file-path=I<perl-module-file-path> (default: C<STDOUT>)
95
96			A platform-dependent file name path for the output.
97			If it is not specified, then the generated Perl module
98			content is outputed to the standard output.
99
100			=item --output-module-version (default) / --nooutput-module-version
101
102			Whether the C<$VERSION> special variable should be generated or not.
103
104			=item --verbose / --noverbose (default)
105
106			Whether a verbose message mode should be selected or not.
107
108			=back
109
110			=cut
111
112			use Getopt::Long;
113			use Pod::Usage;
114			use Storable;
115			use Message::Util::Error;
116			my %Opt;
117			GetOptions (
118			'for=s' => \$Opt{For},
119			'help' => \$Opt{help},
120			'module-uri=s' => \$Opt{module_uri},
121			'output-file-path=s' => \$Opt{output_file_name},
122			) or pod2usage (2);
123			pod2usage ({-exitval => 0, -verbose => 1}) if $Opt{help};
124			$Opt{file_name} = shift;
125			pod2usage ({-exitval => 2, -verbose => 0}) unless $Opt{file_name};
126			pod2usage (2) unless $Opt{module_uri};
127
128			sub status_msg ($) {
129			my $s = shift;
130			$s .= "\n" unless $s =~ /\n$/;
131			print STDERR $s;
132			}
133
134			sub status_msg_ ($) {
135			my $s = shift;
136			print STDERR $s;
137			}
138
139			sub verbose_msg ($) {
140			my $s = shift;
141			$s .= "\n" unless $s =~ /\n$/;
142			print STDERR $s;
143			}
144
145			sub verbose_msg_ ($) {
146			my $s = shift;
147			print STDERR $s;
148			}
149
150			my $impl = $Message::DOM::DOMImplementationRegistry->get_dom_implementation
151			({
152			ExpandedURI q<ManakaiDOM:Minimum> => '3.0',
153			# ExpandedURI q<ManakaiDOM:HTML> => '', # 3.0
154			'+' . ExpandedURI q<DOMLS:LS> => '3.0',
155			'+' . ExpandedURI q<DIS:Doc> => '2.0',
156			ExpandedURI q<DIS:Dump> => '1.0',
157			});
158
159			## -- Load input dac database file
160			status_msg_ qq<Opening dac file "$Opt{file_name}"...>;
161			my $db = $impl->get_feature (ExpandedURI q<DIS:Core> => '1.0')
162			->pl_load_dis_database ($Opt{file_name});
163			status_msg qq<done\n>;
164
165			## -- Load requested module
166			my $mod = $db->get_module ($Opt{module_uri}, for_arg => $Opt{For});
167			unless ($Opt{For}) {
168			my $el = $mod->source_element;
169			if ($el) {
170			$Opt{For} = $el->default_for_uri;
171			$mod = $db->get_module ($Opt{module_uri}, for_arg => $Opt{For});
172			}
173			}
174			unless ($mod->is_defined) {
175			die qq<$0: Module <$Opt{module_uri}> for <$Opt{For}> is not defined>;
176			}
177
178			status_msg qq<Module <$Opt{module_uri}> for <$Opt{For}>...>;
179
180			sub append_module_documentation (%) {
181			my %opt = @_;
182			my $section = $opt{result_parent}->create_module ($opt{source_resource}->uri);
183
184			my $pl_full_name = $opt{source_resource}->pl_fully_qualified_name;
185			if (defined $pl_full_name) {
186			$section->perl_package_name ($pl_full_name);
187			my $path = $pl_full_name;
188			$path =~ s#::#/#g;
189			$section->resource_file_path_stem ($path);
190			$section->set_attribute_ns
191			(ExpandedURI q<ddoct:>, 'ddoct:basePath', '../' x ($path =~ tr#/#/#));
192			}
193
194			$section->resource_file_name_stem ($opt{source_resource}->pl_file_name_stem);
195
196			append_description (source_resource => $opt{source_resource},
197			result_parent => $section);
198
199			for my $rres (@{$opt{source_resource}->get_property_resource_list
200			(ExpandedURI q<DIS:resource>)}) {
201			if ($rres->owner_module eq $opt{source_resource}) { ## Defined in this module
202			## TODO: Modification required to support modplans
203			print STDERR "*";
204			if ($rres->is_type_uri (ExpandedURI q<ManakaiDOM:Class>)) {
205			append_class_documentation
206			(result_parent => $section,
207			source_resource => $rres);
208			} elsif ($rres->is_type_uri (ExpandedURI q<ManakaiDOM:IF>)) {
209			append_interface_documentation
210			(result_parent => $section,
211			source_resource => $rres);
212			}
213			} else { ## Aliases
214			#
215			}
216			}
217			print STDERR "\n";
218			} # append_module_documentation
219
220			sub append_interface_documentation (%) {
221			my %opt = @_;
222			my $section = $opt{result_parent}->create_interface
223			($opt{source_resource}->uri);
224
225			my $pl_full_name = $opt{source_resource}->pl_fully_qualified_name;
226			if (defined $pl_full_name) {
227			$section->perl_package_name ($pl_full_name);
228			my $path = $pl_full_name;
229			$path =~ s#::#/#g;
230			$section->resource_file_path_stem ($path);
231			$section->set_attribute_ns
232			(ExpandedURI q<ddoct:>, 'ddoct:basePath',
233			join '', '../' x ($path =~ tr#/#/#));
234			}
235
236			$section->resource_file_name_stem ($opt{source_resource}->pl_file_name_stem);
237
238			$section->is_exception_interface (1)
239			if $opt{source_resource}->is_type_uri
240			(ExpandedURI q<ManakaiDOM:ExceptionIF>);
241
242			append_description (source_resource => $opt{source_resource},
243			result_parent => $section);
244
245			## Inheritance
246			append_inheritance (source_resource => $opt{source_resource},
247			result_parent => $section);
248
249			for my $memres (@{$opt{source_resource}->get_property_resource_list
250			(ExpandedURI q<DIS:childResource>)}) {
251			if ($memres->is_type_uri (ExpandedURI q<DISLang:Method>)) {
252			append_method_documentation (source_resource => $memres,
253			result_parent => $section);
254			} elsif ($memres->is_type_uri (ExpandedURI q<DISLang:Attribute>)) {
255			append_attr_documentation (source_resource => $memres,
256			result_parent => $section);
257			} elsif ($memres->is_type_uri (ExpandedURI q<ManakaiDOM:ConstGroup>)) {
258
259			}
260			}
261			} # append_interface_documentation
262
263			sub append_class_documentation (%) {
264			my %opt = @_;
265			my $section = $opt{result_parent}->create_class ($opt{source_resource}->uri);
266
267			my $pl_full_name = $opt{source_resource}->pl_fully_qualified_name;
268			if (defined $pl_full_name) {
269			$section->perl_package_name ($pl_full_name);
270			my $path = $pl_full_name;
271			$path =~ s#::#/#g;
272			$section->resource_file_path_stem ($path);
273			$section->set_attribute_ns
274			(ExpandedURI q<ddoct:>, 'ddoct:basePath', '../' x ($path =~ tr#/#/#));
275			}
276
277			$section->resource_file_name_stem ($opt{source_resource}->pl_file_name_stem);
278
279			append_description (source_resource => $opt{source_resource},
280			result_parent => $section);
281
282			## Inheritance
283			append_inheritance (source_resource => $opt{source_resource},
284			result_parent => $section,
285			append_implements => 1);
286
287			for my $memres (@{$opt{source_resource}->get_property_resource_list
288			(ExpandedURI q<DIS:childResource>)}) {
289			if ($memres->is_type_uri (ExpandedURI q<DISLang:Method>)) {
290			append_method_documentation (source_resource => $memres,
291			result_parent => $section);
292			} elsif ($memres->is_type_uri (ExpandedURI q<DISLang:Attribute>)) {
293			append_attr_documentation (source_resource => $memres,
294			result_parent => $section);
295			} elsif ($memres->is_type_uri (ExpandedURI q<ManakaiDOM:Const>)) {
296
297			} elsif ($memres->is_type_uri (ExpandedURI q<ManakaiDOM:ConstGroup>)) {
298
299			}
300			}
301			} # append_class_documentation
302
303			sub append_method_documentation (%) {
304			my %opt = @_;
305			my $perl_name = $opt{source_resource}->pl_name;
306			my $m;
307			if (defined $perl_name) {
308			$m = $opt{result_parent}->create_method ($perl_name);
309
310			} else { ## Anonymous
311			## TODO
312			return;
313			}
314
315			$m->add_uri ($opt{source_resource}->uri);
316
317			append_description (source_resource => $opt{source_resource},
318			result_parent => $m);
319
320			my $ret = $opt{source_resource}->get_child_resource_by_type
321			(ExpandedURI q<DISLang:MethodReturn>);
322			if ($ret) {
323			my $r = $m->dis_return;
324
325			try {
326			$r->resource_data_type ($ret->dis_data_type_resource->uri);
327			$r->resource_actual_data_type ($ret->dis_actual_data_type_resource->uri);
328
329			append_description (source_resource => $ret,
330			result_parent => $r,
331			has_case => 1);
332
333			## TODO: Exceptions
334			} catch Message::Util::DIS::ManakaiDISException with {
335
336			};
337			}
338
339			for my $cr (@{$opt{source_resource}->get_property_resource_list
340			(ExpandedURI q<DIS:childResource>)}) {
341			if ($cr->is_type_uri (ExpandedURI q<DISLang:MethodParameter>)) {
342			append_param_documentation (source_resource => $cr,
343			result_parent => $m);
344			}
345			}
346
347			## TODO: raises
348
349			$m->resource_access ('private')
350			if $opt{source_resource}->get_property_boolean
351			(ExpandedURI q<ManakaiDOM:isForInternal>, 0);
352			} # append_method_documentation
353
354			sub append_attr_documentation (%) {
355			my %opt = @_;
356			my $perl_name = $opt{source_resource}->pl_name;
357			my $m;
358			if (defined $perl_name) {
359			$m = $opt{result_parent}->create_attribute ($perl_name);
360
361			} else { ## Anonymous
362			## TODO
363			return;
364			}
365
366			$m->add_uri ($opt{source_resource}->uri);
367
368			append_description (source_resource => $opt{source_resource},
369			result_parent => $m,
370			has_case => 1);
371
372			my $ret = $opt{source_resource}->get_child_resource_by_type
373			(ExpandedURI q<DISLang:AttributeGet>);
374			if ($ret) {
375			my $r = $m->dis_get;
376
377			$r->resource_data_type ($ret->dis_data_type_resource->uri);
378			$r->resource_actual_data_type ($ret->dis_actual_data_type_resource->uri);
379
380			append_description (source_resource => $ret,
381			result_parent => $r,
382			has_case => 1);
383
384			## TODO: Exceptions
385			}
386
387			my $set = $opt{source_resource}->get_child_resource_by_type
388			(ExpandedURI q<DISLang:AttributeSet>);
389			if ($set) {
390			my $r = $m->dis_set;
391
392			$r->resource_data_type ($set->dis_data_type_resource->uri);
393			$r->resource_actual_data_type ($set->dis_actual_data_type_resource->uri);
394
395			append_description (source_resource => $set,
396			result_parent => $r,
397			has_case => 1);
398
399			## TODO: InCase, Exceptions
400			} else {
401			$m->is_read_only_attribute (1);
402			}
403
404			$m->resource_access ('private')
405			if $opt{source_resource}->get_property_boolean
406			(ExpandedURI q<ManakaiDOM:isForInternal>, 0);
407			} # append_attr_documentation
408
409			sub append_param_documentation (%) {
410			my %opt = @_;
411
412			my $is_named_param = $opt{source_resource}->get_property_boolean
413			(ExpandedURI q<DISPerl:isNamedParameter>, 0);
414
415			my $perl_name = $is_named_param
416			? $opt{source_resource}->pl_name
417			: $opt{source_resource}->pl_variable_name;
418
419			my $p = $opt{result_parent}->create_parameter ($perl_name, $is_named_param);
420
421			$p->is_nullable_parameter ($opt{source_resource}->pl_is_nullable);
422			$p->resource_data_type ($opt{source_resource}->dis_data_type_resource->uri);
423			$p->resource_actual_data_type
424			($opt{source_resource}->dis_actual_data_type_resource->uri);
425
426			append_description (source_resource => $opt{source_resource},
427			result_parent => $p,
428			has_case => 1);
429			} # append_param_documentation
430
431			sub append_description (%) {
432			my %opt = @_;
433			my $od = $opt{result_parent}->owner_document;
434			my $resd = $opt{source_resource}->get_feature (ExpandedURI q<DIS:Doc>, '2.0');
435			my $doc = $resd->get_description ($od);
436			$opt{result_parent}->create_description->append_child ($doc);
437			## TODO: Negotiation
438
439			if ($opt{has_case}) {
440			for my $caser (@{$opt{source_resource}->get_property_resource_list
441			(ExpandedURI q<DIS:childResource>)}) {
442			if ($caser->is_type_uri (ExpandedURI q<ManakaiDOM:InCase>)) {
443			my $case = $opt{result_parent}->append_case;
444			my $cased = $caser->get_feature (ExpandedURI q<DIS:Doc>, '2.0');
445			my $label = $cased->get_label ($od);
446			if ($label) {
447			$case->create_label->append_child ($label);
448			}
449			my $value = $caser->pl_code_fragment;
450			if ($value) {
451			$case->create_value->text_content ($value->stringify);
452			}
453			append_description (source_resource => $caser,
454			result_parent => $case);
455			}
456			}
457			}
458			} # append_description
459
460			sub append_inheritance (%) {
461			my %opt = @_;
462			if (($opt{depth} \|\|= 0) == 100) {
463			warn "<".$opt{source_resource}->uri.">: Loop in inheritance";
464			return;
465			}
466
467			for my $isa (@{$opt{source_resource}->get_property_resource_list
468			(ExpandedURI q<dis:ISA>,
469			default_media_type => ExpandedURI q<dis:TFQNames>)}) {
470			append_inheritance
471			(source_resource => $isa,
472			result_parent => $opt{result_parent}->append_new_extends ($isa->uri),
473			depth => $opt{depth} + 1);
474			}
475
476			if ($opt{append_implements}) {
477			for my $impl (@{$opt{source_resource}->get_property_resource_list
478			(ExpandedURI q<dis:Implement>,
479			default_media_type => ExpandedURI q<dis:TFQNames>,
480			recursive_isa => 1)}) {
481			append_inheritance
482			(source_resource => $impl,
483			result_parent => $opt{result_parent}->append_new_implements
484			($impl->uri),
485			depth => $opt{depth});
486			}
487			}
488			} # append_inheritance
489
490			my $doc = $impl->create_disdump_document;
491
492			my $body = $doc->document_element;
493
494			append_module_documentation
495			(result_parent => $body,
496			source_resource => $mod);
497
498			my $lsimpl = $impl->get_feature (ExpandedURI q<DOMLS:LS> => '3.0');
499
500			status_msg_ qq<Writing file ""...>;
501
502			use Encode;
503			my $serializer = $lsimpl->create_mls_serializer
504			({ExpandedURI q<DOMLS:SerializeDocumentInstance> => ''});
505			print Encode::encode ('utf8', $serializer->write_to_string ($doc));
506
507			status_msg qq<done>;
508
509			verbose_msg_ qq<Checking undefined resources...>;
510
511			$db->check_undefined_resource;
512
513			verbose_msg qq<done>;
514
515			verbose_msg_ qq<Closing database...>;
516			undef $db;
517			verbose_msg qq<done>;
518
519			=head1 SEE ALSO
520
521			L<lib/manakai/dis.pl> and L<bin/cdis2pm.pl> - Old version of
522			this script.
523
524			L<lib/Message/Util/DIS.dis> - The <QUOTE::dis> object implementation.
525
526			L<lib/Message/Util/PerlCode.dis> - The Perl code generator.
527
528			L<lib/manakai/DISCore.dis> - The definition for the "dis" format.
529
530			L<lib/manakai/DISPerl.dis> - The definition for the "dis" Perl-specific
531			vocabulary.
532
533			=head1 LICENSE
534
535			Copyright 2004-2005 Wakaba <w@suika.fam.cx>. All rights reserved.
536
537			This program is free software; you can redistribute it and/or
538			modify it under the same terms as Perl itself.
539
540			=cut
541
542			1; # $Date: 2005/05/07 13:56:36 $