manakai/bin/daf.pl

#!/usr/bin/perl -w 
use strict;
use Message::Util::QName::Filter {
  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-->,
  dp => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/DIS#Perl/>,
  fe => q<http://suika.fam.cx/www/2006/feature/>,
  ManakaiDOM => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/manakai-dom#>,
  swcfg21 => q<http://suika.fam.cx/~wakaba/archive/2005/swcfg21#>,
  Util => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/>,
};

use Cwd;
use Getopt::Long;
use Pod::Usage;
my %Opt = (create_module => []);
GetOptions (
  'create-perl-module=s' => sub {
    shift;
    my $i = [split /\s+/, shift, 3];
    $i->[3] = 'pm';
    push @{$Opt{create_module}}, $i;
  },
  'debug' => \$Opt{debug},
  'dis-file-suffix=s' => \$Opt{dis_suffix},
  'daem-file-suffix=s' => \$Opt{daem_suffix},
  'dafx-file-suffix=s' => \$Opt{dafx_suffix},
  'help' => \$Opt{help},
  'search-path|I=s' => sub {
    shift;
    my @value = split /\s+/, shift;
    while (my ($ns, $path) = splice @value, 0, 2, ()) {
      unless (defined $path) {
        die qq[$0: Search-path parameter without path: "$ns"];
      }
      push @{$Opt{input_search_path}->{$ns} ||= []}, $path;
    }
  },
  'search-path-catalog-file-name=s' => sub {
    shift;
    require File::Spec;
    my $path = my $path_base = shift;
    $path_base =~ s#[^/]+$##;
    $Opt{search_path_base} = $path_base;
    open my $file, '<', $path or die "$0: $path: $!";
    while (<$file>) {
      if (s/^\s*\@//) {     ## Processing instruction
        my ($target, $data) = split /\s+/;
        if ($target eq 'base') {
          $Opt{search_path_base} = File::Spec->rel2abs ($data, $path_base);
        } else {
          die "$0: $target: Unknown target";
        }
      } elsif (/^\s*\#/) {  ## Comment
        #
      } elsif (/\S/) {      ## Catalog entry
        s/^\s+//;
        my ($ns, $path) = split /\s+/;
        push @{$Opt{input_search_path}->{$ns} ||= []},
             File::Spec->rel2abs ($path, $Opt{search_path_base});
      }
    }
    ## NOTE: File paths with SPACEs are not supported
    ## NOTE: Future version might use file: URI instead of file path.
  },
  'undef-check!' => \$Opt{no_undef_check},
  'verbose!' => \$Opt{verbose},
) or pod2usage (2);
pod2usage ({-exitval => 0, -verbose => 1}) if $Opt{help};
$Opt{no_undef_check} = defined $Opt{no_undef_check}
                         ? $Opt{no_undef_check} ? 0 : 1 : 0;
$Opt{dis_suffix} = '.dis' unless defined $Opt{dis_suffix};
$Opt{daem_suffix} = '.dafm' unless defined $Opt{daem_suffix};
$Opt{dafx_suffix} = '.dafx' unless defined $Opt{dafx_suffix};
$Message::DOM::DOMFeature::DEBUG = 1 if $Opt{debug};
require Error;
$Error::Debug = 1 if $Opt{debug};
$Message::Util::Error::VERBOSE = 1 if $Opt{verbose};

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 if $Opt{verbose};
}

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

my $start_time;
BEGIN { $start_time = time }

use Message::Util::DIS::DNLite;
use Message::Util::PerlCode;

my $limpl = $Message::DOM::ImplementationRegistry->get_implementation
                           ({ExpandedURI q<fe:Min> => '3.0',
                             '+' . ExpandedURI q<DIS:DNLite> => '1.0',
                             '+' . ExpandedURI q<DIS:Core> => '1.0',
                             '+' . ExpandedURI q<Util:PerlCode> => '1.0',
                           });
my $impl = $limpl->get_feature (ExpandedURI q<DIS:Core> => '1.0');
my $parser = $impl->create_dis_parser;
our $DNi = $impl->get_feature (ExpandedURI q<DIS:DNLite> => '1.0');

my $HasError;
my $db = $impl->create_dis_database;
$db->pl_database_module_resolver (\&daf_db_module_resolver);
$db->dom_config->set_parameter ('error-handler' => \&daf_on_error);

my %ModuleSourceDISDocument;
my %ModuleSourceDNLDocument;
my %ModuleNameNamespaceBinding = (
  DISCore => q<http://suika.fam.cx/~wakaba/archive/2004/dis/Core#>,
    ## This builtin binding is required since
    ## some module has |DISCore:author| property before |dis:Require|
    ## property.
);

my @target_modules;
for (@{$Opt{create_module}}) {
  my ($mod_uri, $out_path, $mod_for, $out_type) = @$_;
  push @target_modules, [$mod_uri, $mod_for];
}

my $ResourceCount = 0;
$db->pl_update_module (\@target_modules,
get_module_index_file_name => sub {
  shift; # $db
  daf_get_module_index_file_name (@_);
},
get_module_source_document_from_uri => sub {
  my ($db, $module_uri, $module_for) = @_;
  status_msg '';
  status_msg qq<Loading module <$module_uri> for <$module_for>...>;
  $ResourceCount = 0;

  unless (defined $ModuleSourceDNLDocument{$module_uri}) {
    unless (defined $ModuleSourceDISDocument{$module_uri}) {
      daf_open_source_dis_document ($module_uri);
    }
    daf_convert_dis_document_to_dnl_document ();
  }
  return $ModuleSourceDNLDocument{$module_uri};
},
get_module_source_document_from_resource => sub ($$$$$$) {
  my ($self, $db, $uri, $ns, $ln, $for) = @_;
  status_msg '';
  status_msg qq<Loading module "$ln" for <$for>...>;
  $ResourceCount = 0;

  my $module_uri = $ns.$ln;
  unless (defined $ModuleSourceDNLDocument{$module_uri}) {
    unless (defined $ModuleSourceDISDocument{$module_uri}) {
      daf_open_source_dis_document ($module_uri);
    }
    daf_convert_dis_document_to_dnl_document ();
  }
  return $ModuleSourceDNLDocument{$module_uri};
},
get_module_source_revision => sub {
  my ($db, $module_uri) = @_;
  my $ns = $module_uri;
  $ns =~ s/(\w+)\z//;
  my $ln = $1;

  my $name = dac_search_file_path_stem ($ns, $ln, $Opt{dis_suffix});
  if (defined $name) {
    return [stat $name.$Opt{dis_suffix}]->[9];
  } else {
    return 0;
  }
},
get_referring_module_uri_list => sub {
  my ($db, $module_uri) = @_;
  unless (defined $ModuleSourceDNLDocument{$module_uri}) {
    unless (defined $ModuleSourceDISDocument{$module_uri}) {
      daf_open_source_dis_document ($module_uri);
    }
    daf_convert_dis_document_to_dnl_document ();
  }
  return daf_get_referring_module_uri_list ($module_uri);
},
on_resource_read => sub ($$) {
  if ((++$ResourceCount % 10) == 0) {
    status_msg_ "*";
    status_msg_ " " if ($ResourceCount % (10 * 10)) == 0;
    status_msg '' if ($ResourceCount % (10 * 50)) == 0;
  }
});


## Removes reference from document to database
our @Document;
for my $dis (@Document) {
  $dis->unlink_from_document;
  $dis->dis_database (undef);
}

status_msg '';

status_msg qq<Reading properties...>;
$ResourceCount = 0;
$db->read_properties (on_resource_read => sub ($$) {
  if ((++$ResourceCount % 10) == 0) {
    status_msg_ "*";
    status_msg_ " " if ($ResourceCount % (10 * 10)) == 0;
    status_msg '' if ($ResourceCount % (10 * 50)) == 0;
  }
});
status_msg '';
status_msg "done";

status_msg_ qq<Writing database files...>;
$db->pl_store ('dummy', sub ($$) {
  my ($db, $mod, $type) = @_;
  my $ns = $mod->namespace_uri;
  my $ln = $mod->local_name;
  my $suffix = $type eq ExpandedURI q<dp:ModuleIndexFile>
                 ? $Opt{dafx_suffix} : $Opt{daem_suffix};
  my $name = dac_search_file_path_stem ($ns, $ln, $suffix);
  if (defined $name) {
    $name .= $suffix;
  } elsif (defined ($name = dac_search_file_path_stem
                              ($ns, $ln, $Opt{dis_suffix}))) {
    $name .= $suffix;
  } else {
    $name = Cwd::abs_path
              (File::Spec->canonpath
                 (File::Spec->catfile
                    (defined $Opt{input_search_path}->{$ns}->[0]
                       ? $Opt{input_search_path}->{$ns}->[0] : '.',
                     $ln.$suffix)));
  }
  verbose_msg qq<Database >.
              ($type eq <Q::dp|ModuleIndexFile> ? 'index' : 'module').
              qq< <$ns$ln> is written to "$name">;
  return $name;
}, no_main_database => 1);
status_msg "done";

daf_check_undefined ();

for (@{$Opt{create_module}}) {
  my ($mod_uri, $out_file_path, $mod_for, $out_type) = @$_;
  unless (defined $mod_for) {
    $mod_for = $db->get_module ($mod_uri)
                  ->get_property_text (ExpandedURI q<dis:DefaultFor>,
                                       ExpandedURI q<ManakaiDOM:all>);
  }
  my $mod = $db->get_module ($mod_uri, for_arg => $mod_for);

  if ($out_type eq 'pm') {
    status_msg_ qq<Generating Perl module from <$mod_uri> for <$mod_for>...>;
    my $pl = $mod->pl_generate_perl_module_file;
    status_msg qq<done>;

    my $output;
    defined $out_file_path
        ? (open $output, '>', $out_file_path or die "$0: $out_file_path: $!")
        : ($output = \*STDOUT);

    status_msg_ sprintf qq<Writing Perl module %s...>,
                          defined $out_file_path
                            ? q<">.$out_file_path.q<">
                            : 'to stdout';
    print $output $pl->stringify;
    close $output;
    status_msg q<done>;
  }
}

daf_check_undefined ();

status_msg_ "Closing the database...";
$db->free;
undef $db;
undef %ModuleSourceDNLDocument;
status_msg "done";

undef $DNi;

{
  use integer;
  my $time = time - $start_time;
  status_msg sprintf qq<%d'%02d''>, $time / 60, $time % 60;
}
exit $HasError;

END {
  $db->free if $db;
}

sub daf_open_source_dis_document ($) {
  my ($module_uri) = @_;

  ## -- Finds |dis| source file
  my $ns = $module_uri;
  $ns =~ s/(\w+)\z//;
  my $ln = $1;
  my $file_name = dac_search_file_path_stem ($ns, $ln, $Opt{dis_suffix});
  unless (defined $file_name) {
    die "$0: Source file for <$ns$ln> is not found";
  }
  $file_name .= $Opt{dis_suffix};

  status_msg_ qq<Opening dis source file "$file_name"...>;

  ## -- Opens |dis| file and construct |DISDocument| tree
  open my $file, '<', $file_name or die "$0: $file_name: $!";
  my $dis = $parser->parse ({character_stream => $file});
  require File::Spec;
  $dis->flag (ExpandedURI q<swcfg21:fileName> =>
                  File::Spec->abs2rel ($file_name));
  $dis->dis_namespace_resolver (\&daf_module_name_namespace_resolver);
  close $file;

  ## -- Registers namespace URI
  my $mod = $dis->module_element;
  if ($mod) {
    my $qn = $mod->get_attribute_ns (ExpandedURI q<dis:>, 'QName');
    if ($qn) {
      my $prefix = $qn->value;
      $prefix =~ s/^[^:|]*[:|]\s*//;
      $prefix =~ s/\s+$//;
      unless (defined $ModuleNameNamespaceBinding{$prefix}) {
        $ModuleNameNamespaceBinding{$prefix} = $mod->defining_namespace_uri;
      }
    }
  }

  $ModuleSourceDISDocument{$module_uri} = $dis;
  status_msg q<done>;

  R: for (@{daf_get_referring_module_uri_list ($module_uri)}) {
    next R if defined $db->{modDef}->{$_};
    next R if defined $ModuleSourceDNLDocument{$_};
    next R if defined $ModuleSourceDISDocument{$_};
    my $idx_file_name = daf_get_module_index_file_name ($_);
    if (-f $idx_file_name) {
      daf_open_current_module_index ($_, $idx_file_name);
    } else {
      daf_open_source_dis_document ($_);
    }
  }
} # daf_open_source_dis_document

sub daf_open_current_module_index ($$) {
  my ($module_uri, $file_name) = @_;
  $db->pl_load_dis_database_index ($file_name);

  R: for (@{$db->get_module ($module_uri)
               ->get_referring_module_uri_list}) {
    next R if defined $db->{modDef}->{$_};
    next R if defined $ModuleSourceDNLDocument{$_};
    next R if defined $ModuleSourceDISDocument{$_};
    my $idx_file_name = daf_get_module_index_file_name ($_);
    if (-f $idx_file_name) {
      daf_open_current_module_index ($_, $idx_file_name);
    } else {
      daf_open_source_dis_document ($_);
    }
  }
} # daf_open_current_module_index

sub daf_convert_dis_document_to_dnl_document () {
  M: for my $module_uri (keys %ModuleSourceDISDocument) {
    my $dis_doc = $ModuleSourceDISDocument{$module_uri};
    next M unless $dis_doc;
    verbose_msg_ qq<Converting <$module_uri>...>;
    my $dnl_doc = $DNi->convert_dis_document_to_dnl_document
                          ($dis_doc, database_arg => $db,
                           base_namespace_binding =>
                             {(map {$_->local_name => $_->target_namespace_uri}
                               grep {$_} values %{$db->{modDef}}),
                              %ModuleNameNamespaceBinding});
    push @Document, $dnl_doc;
    $ModuleSourceDNLDocument{$module_uri} = $dnl_doc;
    $dis_doc->free;
    delete $ModuleSourceDISDocument{$module_uri};
    verbose_msg q<done>;
  }
} # daf_convert_dis_document_to_dnl_document

sub daf_get_referring_module_uri_list ($) {
  my $module_uri = shift;
  my $ns = $module_uri;
  $ns =~ s/\w+\z//;
  my $src = $ModuleSourceDNLDocument{$module_uri};
  $src = $ModuleSourceDISDocument{$module_uri} unless defined $src;
  my $mod_el = $src->module_element;
  my $r = [];
  if ($mod_el) {
    my $req_el = $mod_el->require_element;
    if ($req_el) {
      M: for my $m_el (@{$req_el->child_nodes}) {
        next M unless $m_el->node_type eq '#element';
        next M unless $m_el->expanded_uri eq ExpandedURI q<dis:Module>;
        my $qn_el = $m_el->get_attribute_ns (ExpandedURI q<dis:>, 'QName');
        if ($qn_el) {
          push @$r, $qn_el->qname_value_uri;
        } else {
          my $n_el = $m_el->get_attribute_ns (ExpandedURI q<dis:>, 'Name');
          if ($n_el) {
            push @$r, $ns.$n_el->value;
          } else {
            # The module itself
          }
        }
      }
    }
  }
  return $r;
} # daf_get_referring_module_uri_list

sub dac_search_file_path_stem ($$$) {
  my ($ns, $ln, $suffix) = @_;
  require File::Spec;
  for my $dir ('.', @{$Opt{input_search_path}->{$ns}||[]}) {
    my $name = Cwd::abs_path
        (File::Spec->canonpath
         (File::Spec->catfile ($dir, $ln)));
    if (-f $name.$suffix) {
      return $name;
    }
  }
  return undef;
} # dac_search_file_path_stem;

sub daf_get_module_index_file_name ($$) {
  my ($module_uri) = @_;
  my $ns = $module_uri;
  $ns =~ s/(\w+)\z//;
  my $ln = $1;

  verbose_msg qq<Database module index <$module_uri> is requested>;
  my $suffix = $Opt{dafx_suffix};
  my $name = dac_search_file_path_stem ($ns, $ln, $suffix);
  if (defined $name) {
    $name .= $suffix;
  } elsif (defined ($name = dac_search_file_path_stem
                              ($ns, $ln, $Opt{dis_suffix}))) {
    $name .= $suffix;
  } else {
    $name = Cwd::abs_path
              (File::Spec->canonpath
                 (File::Spec->catfile
                    (defined $Opt{input_search_path}->{$ns}->[0]
                       ? $Opt{input_search_path}->{$ns}->[0] : '.',
                     $ln.$suffix)));
  }
  return $name;  
} # daf_get_module_index_file_name

sub daf_module_name_namespace_resolver ($) {
  my $prefix = shift;

  ## -- From modules in database
  M: for (values %{$db->{modDef}}) {
    my $mod = $_;
    next M unless defined $mod;
    if ($mod->local_name eq $prefix) {
      return $mod->target_namespace_uri;
    }
  }

  ## -- From not-in-database-yet module list
  if (defined $ModuleNameNamespaceBinding{$prefix}) {
    return $ModuleNameNamespaceBinding{$prefix};
  }
  return undef;
} # daf_module_name_namespace_resolver

sub daf_db_module_resolver ($$$) {
  my ($db, $mod, $type) = @_;
  my $ns = $mod->namespace_uri;
  my $ln = $mod->local_name;
  my $suffix = $type eq ExpandedURI q<dp:ModuleIndexFile>
                 ? $Opt{dafx_suffix} : $Opt{daem_suffix};
  verbose_msg qq<Database module <$ns$ln> is requested>;
  my $name = dac_search_file_path_stem ($ns, $ln, $suffix);
  if (defined $name) {
    return $name.$suffix;
  } else {
    return undef;
  }
} # daf_db_module_resolver

sub daf_on_error ($$) {
  my ($self, $err) = @_;
  if ($err->severity == $err->SEVERITY_WARNING) {
    my $info = ExpandedURI q<dp:info>;
    if ($err->type =~ /\Q$info\E/) {
      my $msg = $err->text;
      if ($msg =~ /\.\.\.\z/) {
        verbose_msg_ $msg;
      } else {
        verbose_msg $msg;
      }
    } else {
      my $msg = $err->text;
      if ($msg =~ /\.\.\.\z/) {
        status_msg_ $msg;
      } else {
        status_msg $msg;
      }
    }
  } else {
    warn $err;
    $HasError = 1;
  }
} # daf_on_error

sub daf_check_undefined () {
  unless ($Opt{no_undef_check}) {
    status_msg_ "Checking undefined resources...";
    $db->check_undefined_resource;
    print STDERR "done\n";
  }
} # daf_check_undefined

__END__

=head1 NAME

dac.pl - Creating "dac" Database File from "dis" Source Files

=head1 SYNOPSIS

  perl path/to/dac.pl [--input-db-file-name=input.dac] \
                      --output-file-name=out.dac [options...] \
                      input.dis
  perl path/to/dac.pl --help

=head1 DESCRIPTION

This script, C<dac.pl>, compiles "dis" source files into "dac"
database file.  The generated database file can be used
in turn to generate Perl module file, for example, by another
script C<dac2pm.pl> or can be used to create larger database
by specifying its file name as the C<--input-db-file-name>
argument of another C<dac.pl> execution.

This script is part of manakai.

=head1 OPTIONS

=over 4

=item I<input.dis> (Required)

The unnamed option specifies a file name path of the source "dis" file
from which a database is created.  This option is required.

=item C<--input-db-file-name=I<file-name>> (Default: none)

A file path of the base database.  This option is optional; if this
option is specified, the database file is loaded first
and then I<input.dis> file is loaded in the context of it.
Otherwise, a new database is created.

=item C<--output-file-name=I<file-name>> (Required)

The 

=back

=head1 SEE ALSO

L<bin/dac2pm.pl> - Generating Perl module from "dac" file.

L<lib/Message/Util/DIS.dis> - The actual implementation
of the "dis" interpretation.

=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	wakaba	1.1	#!/usr/bin/perl -w
2			use strict;
3			use Message::Util::QName::Filter {
4			DIS => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/DIS#>,
5			dis => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/lang#dis-->,
6			dp => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/DIS#Perl/>,
7			fe => q<http://suika.fam.cx/www/2006/feature/>,
8			ManakaiDOM => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/manakai-dom#>,
9			swcfg21 => q<http://suika.fam.cx/~wakaba/archive/2005/swcfg21#>,
10			Util => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/>,
11			};
12
13			use Cwd;
14			use Getopt::Long;
15			use Pod::Usage;
16			my %Opt = (create_module => []);
17			GetOptions (
18			'create-perl-module=s' => sub {
19			shift;
20			my $i = [split /\s+/, shift, 3];
21			$i->[3] = 'pm';
22			push @{$Opt{create_module}}, $i;
23			},
24			'debug' => \$Opt{debug},
25			'dis-file-suffix=s' => \$Opt{dis_suffix},
26			'daem-file-suffix=s' => \$Opt{daem_suffix},
27			'dafx-file-suffix=s' => \$Opt{dafx_suffix},
28			'help' => \$Opt{help},
29			'search-path\|I=s' => sub {
30			shift;
31			my @value = split /\s+/, shift;
32			while (my ($ns, $path) = splice @value, 0, 2, ()) {
33			unless (defined $path) {
34			die qq[$0: Search-path parameter without path: "$ns"];
35			}
36			push @{$Opt{input_search_path}->{$ns} \|\|= []}, $path;
37			}
38			},
39			'search-path-catalog-file-name=s' => sub {
40			shift;
41			require File::Spec;
42			my $path = my $path_base = shift;
43			$path_base =~ s#[^/]+$##;
44			$Opt{search_path_base} = $path_base;
45			open my $file, '<', $path or die "$0: $path: $!";
46			while (<$file>) {
47			if (s/^\s*\@//) { ## Processing instruction
48			my ($target, $data) = split /\s+/;
49			if ($target eq 'base') {
50			$Opt{search_path_base} = File::Spec->rel2abs ($data, $path_base);
51			} else {
52			die "$0: $target: Unknown target";
53			}
54			} elsif (/^\s*\#/) { ## Comment
55			#
56			} elsif (/\S/) { ## Catalog entry
57			s/^\s+//;
58			my ($ns, $path) = split /\s+/;
59			push @{$Opt{input_search_path}->{$ns} \|\|= []},
60			File::Spec->rel2abs ($path, $Opt{search_path_base});
61			}
62			}
63			## NOTE: File paths with SPACEs are not supported
64			## NOTE: Future version might use file: URI instead of file path.
65			},
66			'undef-check!' => \$Opt{no_undef_check},
67			'verbose!' => \$Opt{verbose},
68			) or pod2usage (2);
69			pod2usage ({-exitval => 0, -verbose => 1}) if $Opt{help};
70			$Opt{no_undef_check} = defined $Opt{no_undef_check}
71			? $Opt{no_undef_check} ? 0 : 1 : 0;
72			$Opt{dis_suffix} = '.dis' unless defined $Opt{dis_suffix};
73			$Opt{daem_suffix} = '.dafm' unless defined $Opt{daem_suffix};
74			$Opt{dafx_suffix} = '.dafx' unless defined $Opt{dafx_suffix};
75			$Message::DOM::DOMFeature::DEBUG = 1 if $Opt{debug};
76			require Error;
77			$Error::Debug = 1 if $Opt{debug};
78			$Message::Util::Error::VERBOSE = 1 if $Opt{verbose};
79
80			sub status_msg ($) {
81			my $s = shift;
82			$s .= "\n" unless $s =~ /\n$/;
83			print STDERR $s;
84			}
85
86			sub status_msg_ ($) {
87			my $s = shift;
88			print STDERR $s;
89			}
90
91			sub verbose_msg ($) {
92			my $s = shift;
93			$s .= "\n" unless $s =~ /\n$/;
94			print STDERR $s if $Opt{verbose};
95			}
96
97			sub verbose_msg_ ($) {
98			my $s = shift;
99			print STDERR $s if $Opt{verbose};
100			}
101
102			my $start_time;
103			BEGIN { $start_time = time }
104
105			use Message::Util::DIS::DNLite;
106			use Message::Util::PerlCode;
107
108			my $limpl = $Message::DOM::ImplementationRegistry->get_implementation
109			({ExpandedURI q<fe:Min> => '3.0',
110			'+' . ExpandedURI q<DIS:DNLite> => '1.0',
111			'+' . ExpandedURI q<DIS:Core> => '1.0',
112			'+' . ExpandedURI q<Util:PerlCode> => '1.0',
113			});
114			my $impl = $limpl->get_feature (ExpandedURI q<DIS:Core> => '1.0');
115			my $parser = $impl->create_dis_parser;
116			our $DNi = $impl->get_feature (ExpandedURI q<DIS:DNLite> => '1.0');
117
118			my $HasError;
119			my $db = $impl->create_dis_database;
120			$db->pl_database_module_resolver (\&daf_db_module_resolver);
121			$db->dom_config->set_parameter ('error-handler' => \&daf_on_error);
122
123			my %ModuleSourceDISDocument;
124			my %ModuleSourceDNLDocument;
125			my %ModuleNameNamespaceBinding = (
126			DISCore => q<http://suika.fam.cx/~wakaba/archive/2004/dis/Core#>,
127			## This builtin binding is required since
128			## some module has \|DISCore:author\| property before \|dis:Require\|
129			## property.
130			);
131
132			my @target_modules;
133			for (@{$Opt{create_module}}) {
134			my ($mod_uri, $out_path, $mod_for, $out_type) = @$_;
135			push @target_modules, [$mod_uri, $mod_for];
136			}
137
138			my $ResourceCount = 0;
139			$db->pl_update_module (\@target_modules,
140			get_module_index_file_name => sub {
141			shift; # $db
142			daf_get_module_index_file_name (@_);
143			},
144			get_module_source_document_from_uri => sub {
145			my ($db, $module_uri, $module_for) = @_;
146			status_msg '';
147			status_msg qq<Loading module <$module_uri> for <$module_for>...>;
148			$ResourceCount = 0;
149
150			unless (defined $ModuleSourceDNLDocument{$module_uri}) {
151			unless (defined $ModuleSourceDISDocument{$module_uri}) {
152			daf_open_source_dis_document ($module_uri);
153			}
154			daf_convert_dis_document_to_dnl_document ();
155			}
156			return $ModuleSourceDNLDocument{$module_uri};
157			},
158			get_module_source_document_from_resource => sub ($$$$$$) {
159			my ($self, $db, $uri, $ns, $ln, $for) = @_;
160			status_msg '';
161			status_msg qq<Loading module "$ln" for <$for>...>;
162			$ResourceCount = 0;
163
164			my $module_uri = $ns.$ln;
165			unless (defined $ModuleSourceDNLDocument{$module_uri}) {
166			unless (defined $ModuleSourceDISDocument{$module_uri}) {
167			daf_open_source_dis_document ($module_uri);
168			}
169			daf_convert_dis_document_to_dnl_document ();
170			}
171			return $ModuleSourceDNLDocument{$module_uri};
172			},
173			get_module_source_revision => sub {
174			my ($db, $module_uri) = @_;
175			my $ns = $module_uri;
176			$ns =~ s/(\w+)\z//;
177			my $ln = $1;
178
179			my $name = dac_search_file_path_stem ($ns, $ln, $Opt{dis_suffix});
180			if (defined $name) {
181			return [stat $name.$Opt{dis_suffix}]->[9];
182			} else {
183			return 0;
184			}
185			},
186			get_referring_module_uri_list => sub {
187			my ($db, $module_uri) = @_;
188			unless (defined $ModuleSourceDNLDocument{$module_uri}) {
189			unless (defined $ModuleSourceDISDocument{$module_uri}) {
190			daf_open_source_dis_document ($module_uri);
191			}
192			daf_convert_dis_document_to_dnl_document ();
193			}
194			return daf_get_referring_module_uri_list ($module_uri);
195			},
196			on_resource_read => sub ($$) {
197			if ((++$ResourceCount % 10) == 0) {
198			status_msg_ "*";
199			status_msg_ " " if ($ResourceCount % (10 * 10)) == 0;
200			status_msg '' if ($ResourceCount % (10 * 50)) == 0;
201			}
202			});
203
204
205			## Removes reference from document to database
206			our @Document;
207			for my $dis (@Document) {
208			$dis->unlink_from_document;
209			$dis->dis_database (undef);
210			}
211
212			status_msg '';
213
214			status_msg qq<Reading properties...>;
215			$ResourceCount = 0;
216			$db->read_properties (on_resource_read => sub ($$) {
217			if ((++$ResourceCount % 10) == 0) {
218			status_msg_ "*";
219			status_msg_ " " if ($ResourceCount % (10 * 10)) == 0;
220			status_msg '' if ($ResourceCount % (10 * 50)) == 0;
221			}
222			});
223			status_msg '';
224			status_msg "done";
225
226			status_msg_ qq<Writing database files...>;
227			$db->pl_store ('dummy', sub ($$) {
228			my ($db, $mod, $type) = @_;
229			my $ns = $mod->namespace_uri;
230			my $ln = $mod->local_name;
231			my $suffix = $type eq ExpandedURI q<dp:ModuleIndexFile>
232			? $Opt{dafx_suffix} : $Opt{daem_suffix};
233			my $name = dac_search_file_path_stem ($ns, $ln, $suffix);
234			if (defined $name) {
235			$name .= $suffix;
236			} elsif (defined ($name = dac_search_file_path_stem
237			($ns, $ln, $Opt{dis_suffix}))) {
238			$name .= $suffix;
239			} else {
240			$name = Cwd::abs_path
241			(File::Spec->canonpath
242			(File::Spec->catfile
243			(defined $Opt{input_search_path}->{$ns}->[0]
244			? $Opt{input_search_path}->{$ns}->[0] : '.',
245			$ln.$suffix)));
246			}
247			verbose_msg qq<Database >.
248			($type eq <Q::dp\|ModuleIndexFile> ? 'index' : 'module').
249			qq< <$ns$ln> is written to "$name">;
250			return $name;
251			}, no_main_database => 1);
252			status_msg "done";
253
254			daf_check_undefined ();
255
256			for (@{$Opt{create_module}}) {
257			my ($mod_uri, $out_file_path, $mod_for, $out_type) = @$_;
258			unless (defined $mod_for) {
259			$mod_for = $db->get_module ($mod_uri)
260			->get_property_text (ExpandedURI q<dis:DefaultFor>,
261			ExpandedURI q<ManakaiDOM:all>);
262			}
263			my $mod = $db->get_module ($mod_uri, for_arg => $mod_for);
264
265			if ($out_type eq 'pm') {
266			status_msg_ qq<Generating Perl module from <$mod_uri> for <$mod_for>...>;
267			my $pl = $mod->pl_generate_perl_module_file;
268			status_msg qq<done>;
269
270			my $output;
271			defined $out_file_path
272			? (open $output, '>', $out_file_path or die "$0: $out_file_path: $!")
273			: ($output = \*STDOUT);
274
275			status_msg_ sprintf qq<Writing Perl module %s...>,
276			defined $out_file_path
277			? q<">.$out_file_path.q<">
278			: 'to stdout';
279			print $output $pl->stringify;
280			close $output;
281			status_msg q<done>;
282			}
283			}
284
285			daf_check_undefined ();
286
287			status_msg_ "Closing the database...";
288			$db->free;
289			undef $db;
290			undef %ModuleSourceDNLDocument;
291			status_msg "done";
292
293			undef $DNi;
294
295			{
296			use integer;
297			my $time = time - $start_time;
298			status_msg sprintf qq<%d'%02d''>, $time / 60, $time % 60;
299			}
300			exit $HasError;
301
302			END {
303			$db->free if $db;
304			}
305
306			sub daf_open_source_dis_document ($) {
307			my ($module_uri) = @_;
308
309			## -- Finds \|dis\| source file
310			my $ns = $module_uri;
311			$ns =~ s/(\w+)\z//;
312			my $ln = $1;
313			my $file_name = dac_search_file_path_stem ($ns, $ln, $Opt{dis_suffix});
314			unless (defined $file_name) {
315			die "$0: Source file for <$ns$ln> is not found";
316			}
317			$file_name .= $Opt{dis_suffix};
318
319			status_msg_ qq<Opening dis source file "$file_name"...>;
320
321			## -- Opens \|dis\| file and construct \|DISDocument\| tree
322			open my $file, '<', $file_name or die "$0: $file_name: $!";
323			my $dis = $parser->parse ({character_stream => $file});
324			require File::Spec;
325			$dis->flag (ExpandedURI q<swcfg21:fileName> =>
326			File::Spec->abs2rel ($file_name));
327			$dis->dis_namespace_resolver (\&daf_module_name_namespace_resolver);
328			close $file;
329
330			## -- Registers namespace URI
331			my $mod = $dis->module_element;
332			if ($mod) {
333			my $qn = $mod->get_attribute_ns (ExpandedURI q<dis:>, 'QName');
334			if ($qn) {
335			my $prefix = $qn->value;
336			$prefix =~ s/^[^:\|][:\|]\s//;
337			$prefix =~ s/\s+$//;
338			unless (defined $ModuleNameNamespaceBinding{$prefix}) {
339			$ModuleNameNamespaceBinding{$prefix} = $mod->defining_namespace_uri;
340			}
341			}
342			}
343
344			$ModuleSourceDISDocument{$module_uri} = $dis;
345			status_msg q<done>;
346
347			R: for (@{daf_get_referring_module_uri_list ($module_uri)}) {
348			next R if defined $db->{modDef}->{$_};
349			next R if defined $ModuleSourceDNLDocument{$_};
350			next R if defined $ModuleSourceDISDocument{$_};
351			my $idx_file_name = daf_get_module_index_file_name ($_);
352			if (-f $idx_file_name) {
353			daf_open_current_module_index ($_, $idx_file_name);
354			} else {
355			daf_open_source_dis_document ($_);
356			}
357			}
358			} # daf_open_source_dis_document
359
360			sub daf_open_current_module_index ($$) {
361			my ($module_uri, $file_name) = @_;
362			$db->pl_load_dis_database_index ($file_name);
363
364			R: for (@{$db->get_module ($module_uri)
365			->get_referring_module_uri_list}) {
366			next R if defined $db->{modDef}->{$_};
367			next R if defined $ModuleSourceDNLDocument{$_};
368			next R if defined $ModuleSourceDISDocument{$_};
369			my $idx_file_name = daf_get_module_index_file_name ($_);
370			if (-f $idx_file_name) {
371			daf_open_current_module_index ($_, $idx_file_name);
372			} else {
373			daf_open_source_dis_document ($_);
374			}
375			}
376			} # daf_open_current_module_index
377
378			sub daf_convert_dis_document_to_dnl_document () {
379			M: for my $module_uri (keys %ModuleSourceDISDocument) {
380			my $dis_doc = $ModuleSourceDISDocument{$module_uri};
381			next M unless $dis_doc;
382			verbose_msg_ qq<Converting <$module_uri>...>;
383			my $dnl_doc = $DNi->convert_dis_document_to_dnl_document
384			($dis_doc, database_arg => $db,
385			base_namespace_binding =>
386			{(map {$_->local_name => $_->target_namespace_uri}
387			grep {$_} values %{$db->{modDef}}),
388			%ModuleNameNamespaceBinding});
389			push @Document, $dnl_doc;
390			$ModuleSourceDNLDocument{$module_uri} = $dnl_doc;
391			$dis_doc->free;
392			delete $ModuleSourceDISDocument{$module_uri};
393			verbose_msg q<done>;
394			}
395			} # daf_convert_dis_document_to_dnl_document
396
397			sub daf_get_referring_module_uri_list ($) {
398			my $module_uri = shift;
399			my $ns = $module_uri;
400			$ns =~ s/\w+\z//;
401			my $src = $ModuleSourceDNLDocument{$module_uri};
402			$src = $ModuleSourceDISDocument{$module_uri} unless defined $src;
403			my $mod_el = $src->module_element;
404			my $r = [];
405			if ($mod_el) {
406			my $req_el = $mod_el->require_element;
407			if ($req_el) {
408			M: for my $m_el (@{$req_el->child_nodes}) {
409			next M unless $m_el->node_type eq '#element';
410			next M unless $m_el->expanded_uri eq ExpandedURI q<dis:Module>;
411			my $qn_el = $m_el->get_attribute_ns (ExpandedURI q<dis:>, 'QName');
412			if ($qn_el) {
413			push @$r, $qn_el->qname_value_uri;
414			} else {
415			my $n_el = $m_el->get_attribute_ns (ExpandedURI q<dis:>, 'Name');
416			if ($n_el) {
417			push @$r, $ns.$n_el->value;
418			} else {
419			# The module itself
420			}
421			}
422			}
423			}
424			}
425			return $r;
426			} # daf_get_referring_module_uri_list
427
428			sub dac_search_file_path_stem ($$$) {
429			my ($ns, $ln, $suffix) = @_;
430			require File::Spec;
431			for my $dir ('.', @{$Opt{input_search_path}->{$ns}\|\|[]}) {
432			my $name = Cwd::abs_path
433			(File::Spec->canonpath
434			(File::Spec->catfile ($dir, $ln)));
435			if (-f $name.$suffix) {
436			return $name;
437			}
438			}
439			return undef;
440			} # dac_search_file_path_stem;
441
442			sub daf_get_module_index_file_name ($$) {
443			my ($module_uri) = @_;
444			my $ns = $module_uri;
445			$ns =~ s/(\w+)\z//;
446			my $ln = $1;
447
448			verbose_msg qq<Database module index <$module_uri> is requested>;
449			my $suffix = $Opt{dafx_suffix};
450			my $name = dac_search_file_path_stem ($ns, $ln, $suffix);
451			if (defined $name) {
452			$name .= $suffix;
453			} elsif (defined ($name = dac_search_file_path_stem
454			($ns, $ln, $Opt{dis_suffix}))) {
455			$name .= $suffix;
456			} else {
457			$name = Cwd::abs_path
458			(File::Spec->canonpath
459			(File::Spec->catfile
460			(defined $Opt{input_search_path}->{$ns}->[0]
461			? $Opt{input_search_path}->{$ns}->[0] : '.',
462			$ln.$suffix)));
463			}
464			return $name;
465			} # daf_get_module_index_file_name
466
467			sub daf_module_name_namespace_resolver ($) {
468			my $prefix = shift;
469
470			## -- From modules in database
471			M: for (values %{$db->{modDef}}) {
472			my $mod = $_;
473			next M unless defined $mod;
474			if ($mod->local_name eq $prefix) {
475			return $mod->target_namespace_uri;
476			}
477			}
478
479			## -- From not-in-database-yet module list
480			if (defined $ModuleNameNamespaceBinding{$prefix}) {
481			return $ModuleNameNamespaceBinding{$prefix};
482			}
483			return undef;
484			} # daf_module_name_namespace_resolver
485
486			sub daf_db_module_resolver ($$$) {
487			my ($db, $mod, $type) = @_;
488			my $ns = $mod->namespace_uri;
489			my $ln = $mod->local_name;
490			my $suffix = $type eq ExpandedURI q<dp:ModuleIndexFile>
491			? $Opt{dafx_suffix} : $Opt{daem_suffix};
492			verbose_msg qq<Database module <$ns$ln> is requested>;
493			my $name = dac_search_file_path_stem ($ns, $ln, $suffix);
494			if (defined $name) {
495			return $name.$suffix;
496			} else {
497			return undef;
498			}
499			} # daf_db_module_resolver
500
501			sub daf_on_error ($$) {
502			my ($self, $err) = @_;
503			if ($err->severity == $err->SEVERITY_WARNING) {
504			my $info = ExpandedURI q<dp:info>;
505			if ($err->type =~ /\Q$info\E/) {
506			my $msg = $err->text;
507			if ($msg =~ /\.\.\.\z/) {
508			verbose_msg_ $msg;
509			} else {
510			verbose_msg $msg;
511			}
512			} else {
513			my $msg = $err->text;
514			if ($msg =~ /\.\.\.\z/) {
515			status_msg_ $msg;
516			} else {
517			status_msg $msg;
518			}
519			}
520			} else {
521			warn $err;
522			$HasError = 1;
523			}
524			} # daf_on_error
525
526			sub daf_check_undefined () {
527			unless ($Opt{no_undef_check}) {
528			status_msg_ "Checking undefined resources...";
529			$db->check_undefined_resource;
530			print STDERR "done\n";
531			}
532			} # daf_check_undefined
533
534			__END__
535
536			=head1 NAME
537
538			dac.pl - Creating "dac" Database File from "dis" Source Files
539
540			=head1 SYNOPSIS
541
542			perl path/to/dac.pl [--input-db-file-name=input.dac] \
543			--output-file-name=out.dac [options...] \
544			input.dis
545			perl path/to/dac.pl --help
546
547			=head1 DESCRIPTION
548
549			This script, C<dac.pl>, compiles "dis" source files into "dac"
550			database file. The generated database file can be used
551			in turn to generate Perl module file, for example, by another
552			script C<dac2pm.pl> or can be used to create larger database
553			by specifying its file name as the C<--input-db-file-name>
554			argument of another C<dac.pl> execution.
555
556			This script is part of manakai.
557
558			=head1 OPTIONS
559
560			=over 4
561
562			=item I<input.dis> (Required)
563
564			The unnamed option specifies a file name path of the source "dis" file
565			from which a database is created. This option is required.
566
567			=item C<--input-db-file-name=I<file-name>> (Default: none)
568
569			A file path of the base database. This option is optional; if this
570			option is specified, the database file is loaded first
571			and then I<input.dis> file is loaded in the context of it.
572			Otherwise, a new database is created.
573
574			=item C<--output-file-name=I<file-name>> (Required)
575
576			The
577
578			=back
579
580			=head1 SEE ALSO
581
582			L<bin/dac2pm.pl> - Generating Perl module from "dac" file.
583
584			L<lib/Message/Util/DIS.dis> - The actual implementation
585			of the "dis" interpretation.
586
587			=head1 LICENSE
588
589			Copyright 2004-2005 Wakaba <w@suika.fam.cx>. All rights reserved.
590
591			This program is free software; you can redistribute it and/or
592			modify it under the same terms as Perl itself.
593
594			=cut