manakai/bin/daf.pl

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

our$VERSION=do{my @r=(q$Revision: 1.23 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
use Cwd;
use Getopt::Long;
use Pod::Usage;
our %Opt = (create_module => []);
my @target_modules;
GetOptions (
  'create-dtd-driver=s' => sub {
    shift;
    my $i = [split /\s+/, shift, 3];
    $i->[3] = 'dtd-driver';
    push @{$Opt{create_module}}, $i;
  },
  'create-dtd-modules=s' => sub {
    shift;
    my $i = [split /\s+/, shift, 3];
    $i->[3] = 'dtd-modules';
    push @{$Opt{create_module}}, $i;
  },
  'create-perl-module=s' => sub {
    shift;
    my $i = [split /\s+/, shift, 3];
    $i->[3] = 'perl-pm';
    push @{$Opt{create_module}}, $i;
    push @target_modules, $i->[0];
  },
  'create-perl-test=s' => sub {
    shift;
    my $i = [split /\s+/, shift, 3];
    $i->[3] = 'perl-t';
    push @{$Opt{create_module}}, $i;
    push @target_modules, $i->[0];
  },
  'debug' => \$Opt{debug},
  'dis-file-suffix=s' => \$Opt{dis_suffix},
  'daem-file-suffix=s' => \$Opt{daem_suffix},
  'dafs-file-suffix=s' => \$Opt{dafs_suffix},
  'dafx-file-suffix=s' => \$Opt{dafx_suffix},
  'dtd-file-suffix=s' => \$Opt{dtd_suffix},
  'help' => \$Opt{help},
  'load-module=s' => sub {
    shift;
    my $i = [split /\s+/, shift, 2];
    push @target_modules, $i->[0];
  },
  'mod-file-suffix=s' => \$Opt{mod_suffix},
  '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};
$Opt{dafs_suffix} = '.dafs' unless defined $Opt{dafs_suffix};
$Opt{dtd_suffix} = '.dtd' unless defined $Opt{dtd_suffix};
$Opt{mod_suffix} = '.mod' unless defined $Opt{mod_suffix};
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};
}

sub daf_open_source_dis_document ($);
sub daf_open_current_module_index ($$);
sub daf_convert_dis_document_to_dnl_document ();
sub daf_get_referring_module_uri_list ($);
sub dac_search_file_path_stem ($$$);
sub daf_get_module_index_file_name ($);
sub daf_check_undefined ();

## ---- The MAIN Program

my $start_time;
BEGIN { $start_time = time }

use Message::DOM::DOMCore;

for (@{$Opt{create_module}}) {
  my (undef, undef, undef, $out_type) = @$_;

  if ($out_type eq 'perl-pm') {
    require 'manakai/daf-perl-pm.pl';
  } elsif ($out_type eq 'perl-t') {
    require 'manakai/daf-perl-t.pl';
  } elsif ($out_type eq 'dtd-modules') {
    require 'manakai/daf-dtd-modules.pl';
  } elsif ($out_type eq 'dtd-driver') {
    require 'manakai/daf-dtd-modules.pl';
  }
}

our $impl = $Message::DOM::ImplementationRegistry->get_dom_implementation;

## --- Loading and Updating the Database

my $HasError;
our $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 $parser = $impl->create_dis_parser;
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 $ResourceCount = 0;
$db->pl_update_module (\@target_modules,
get_module_index_file_name => sub {
  shift; # $db
  daf_get_module_index_file_name (shift);
},
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) = @_;
  status_msg '';
  status_msg qq<Loading module "$ln"...>;
  $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);
    }
  }
  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;
  }
}, implementation => $impl);
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 ();

undef %ModuleSourceDNLDocument;
exit $HasError if $HasError;

## --- Creating Files

for (@{$Opt{create_module}}) {
  my ($mod_uri, $out_file_path, undef, $out_type) = @$_;

  if ($out_type eq 'perl-pm') {
    daf_perl_pm ($mod_uri, $out_file_path);
  } elsif ($out_type eq 'perl-t') {
    daf_perl_t ($mod_uri, $out_file_path);
  } elsif ($out_type eq 'dtd-modules') {
    daf_dtd_modules ($mod_uri, $out_file_path);
  } elsif ($out_type eq 'dtd-driver') {
    daf_dtd_driver ($mod_uri, $out_file_path);
  }
}

daf_check_undefined ();

## --- The END

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

undef $impl;

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

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

## ---- Subroutines

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 = $impl->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 = {
    ExpandedURI q<dp:ModuleIndexFile> => $Opt{dafx_suffix},
    ExpandedURI q<dp:ModuleResourceFile> => $Opt{daem_suffix},
    ExpandedURI q<dp:ModuleNodeStorageFile> => $Opt{dafs_suffix},
  }->{$type} or die "Unsupported type: <$type>";
  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.

=back

=head1 SEE ALSO

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

=head1 LICENSE

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