1: # Copyright (c) 1998 Robert Braddock. All rights reserved.
  2: # This program is free software: you can redistribute it and/or
  3: # modify it under the same terms as Perl itself.

  5: package SGML::ElementMap::Driver;
  6: use strict;

  8: use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION $REVISION);  BEGIN {
  9:     @ISA =         qw( Exporter );
 10:     @EXPORT =        ();
 11:     @EXPORT_OK =     ();
 12:     %EXPORT_TAGS =   ();
 13:     $VERSION =       0.2;
 14:     $REVISION =     q$Revision: 1.4 $;
 15: }
 16: use Exporter;

 18: use Carp;

 20: if (!caller()) { die "$0: perl component module, not executable\n"; }



 24: BEGIN {
 25:     sub set_obj_constants {
 26:         my ($pfx, $c, @names) = @_;
 27:         my $code = 'package '.caller().";\n";
 28:         foreach my $n (@names) {
 29:             $code .= 'sub '.$pfx.'_'.$n.' () { return '.$c."; }\n";
 30:             $c += 1;
 31:         }
 32:         $code .= 'sub '.$pfx.'_LAST () { return '.$c."; }\n1;";
 33:         $code = eval $code;
 34:         die $@ unless defined $code;
 35:         return $code;
 36:     }
 37:     set_obj_constants('IDX',0,qw(input_mode markup_mode parser));
 38: }


 41: ######################################################################
 42: # Defaultable Methods

 44: #create empty object
 45: sub new {
 46:     my $proto = shift;
 47:     my $class = ref($proto) || $proto;
 48:     my ($input,$mark,$parser) = 
 49:         ('default',
 50:          (ref($proto)? $proto->[&IDX_markup_mode()] :'xml'),
 51:          '');
 52:     $parser = shift if @_;
 53:     $input  = shift if @_;
 54:     $mark   = shift if @_;
 55:     
 56:     my $self = [];
 57:     $self->[&IDX_input_mode()] = $input;
 58:     $self->[&IDX_markup_mode()] = $mark;
 59:     $self->[&IDX_parser()] = $parser;

 61:     $self = bless $self, $class;
 62:     return $self;
 63: }

 65: # get and set the current input type
 66: sub input {
 67:     my ($self,$type) = @_;
 68:     my $old = $self->[&IDX_input_mode()];
 69:     if (defined $type) {
 70:         $self->[&IDX_input_mode()] = lc $type;
 71:     }
 72:     return $old;
 73: }

 75: # get and set the current markup type
 76: sub markup {
 77:     my ($self,$type) = @_;
 78:     my $old = $self->[&IDX_markup_mode()];
 79:     if (defined $type) {
 80:         $self->[&IDX_markup_mode()] = lc $type;
 81:     }
 82:     return $old;
 83: }

 85: # set and retrieve the current parser object
 86: sub parser {
 87:     my ($self,$parser) = @_;
 88:     my $old = $self->[&IDX_parser()];
 89:     if (defined $parser) {
 90:         $self->[&IDX_parser()] = $parser;
 91:     }
 92:     return $old;
 93: }

 95: #start new traversal of file (for default use by main)
 96: #passed main module and file name as first (normal) argument, 
 97: #   rest are process specific
 98: sub process_xml_file {
 99:     my ($self, $main, $file, @rest) = @_;
100:     $self->markup('xml');
101:     $self->input('file');
102:     return $self->process($main,$file,@rest);
103: }
104: sub process_sgml_file {
105:     my ($self, $main, $file, @rest) = @_;
106:     $self->markup('sgml');
107:     $self->input('file');
108:     return $self->process($main,$file,@rest);
109: }

111: ######################################################################
112: # NON-Defaultable Methods

114: #start new traversal (for use by users)
115: #passed main module as first (normal) argument, rest are process specific
116: sub process {
117:     my $self = shift;
118:     die ref($self)." fails to implement method process(), ".
119:         "required by base class ".__PACKAGE__."\n";
120: }

122: #reparent current event subtree
123: sub reparent_current_subtree {
124:     my ($self,$psname,@extraargs) = @_;
125:     die ref($self)." fails to implement method reparent_current_subtree(), ".
126:         "required by base class ".__PACKAGE__."\n";
127: }

129: #insert event over next event subtree
130: sub reparent_subtrees {
131:     my ($self,$psname,@extraargs) = @_;
132:     die ref($self)." fails to implement method reparent_subtrees(), ".
133:         "required by base class ".__PACKAGE__."\n";
134: }

136: #dispatch on next event subtree
137: #passed main module as first (normal) argument
138: sub dispatch_subtrees {
139:     my $self = shift;
140:     die ref($self)." fails to implement method dispatch_subtrees(), ".
141:         "required by base class ".__PACKAGE__."\n";
142: }

144: #skip over next event subtree
145: sub skip_subtrees {
146:     my $self = shift;
147:     die ref($self)." fails to implement method skip_subtrees(), ".
148:         "required by base class ".__PACKAGE__."\n";
149: }

151: #return the context as a simple path
152: sub context_path {
153:     my $self = shift;
154:     die ref($self)." fails to implement method context_path(), ".
155:         "required by base class ".__PACKAGE__."\n";
156: }

158: 1;