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

  6: package SGML::ElementMap;
  7: use strict;

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

 19: use Carp;

 21: use Hash::Layered;  #this will be factored out after hooks


 24: my $debug = 0;
 25: my $debug_modes = 0;
 26: my $debug_stack = 0;
 27: my $debug_elpath = 0;
 28: my $debug_visit = 0;
 29: my $debug_event = 0;
 30: my $debug_lookup = 0;
 31: my $debug_final = 0;


 34: BEGIN {
 35:     sub set_obj_constants {
 36:         my ($pfx, $c, $names) = @_;
 37:         my $code = '';
 38:         foreach my $n (@$names) {
 39:             $code .= 'sub '.$pfx.'_'.$n.' () { return '.$c."; }\n";
 40:             $c += 1;
 41:         }
 42:         $code .= 'sub '.$pfx.'_LAST () { return '.$c."; }\n1;";
 43:         $code = eval $code;
 44:         die $@ unless defined $code;
 45:         return $code;
 46:     }
 47:     my @main_keys =  qw(state modes var_global var_stack);
 48:     my @state_keys = qw(driver node_path handler_modes handler_mode_stack
 49:                         named_handlers last_gen_name);
 50:     set_obj_constants('IDX_M',0,\@main_keys);
 51:     set_obj_constants('IDX_S',0,\@state_keys);
 52: }


 55: sub new {
 56:     my $proto = shift;
 57:     my $class = ref($proto) || $proto;
 58:     my $self = [(0) x &IDX_M_LAST()];
 59:     # initialize member data
 60:     $$self[&IDX_M_var_stack()] = Hash::Layered->new();
 61:     $$self[&IDX_M_modes()] = { };
 62:     $$self[&IDX_M_var_global()] = { };
 63:     my $state = $$self[&IDX_M_state()] = [(0) x &IDX_S_LAST()];
 64:     # initialize state sub data
 65:     $$state[&IDX_S_driver()] = ref($proto) ? $proto->driver : '';
 66:     $$state[&IDX_S_node_path()] = '';
 67:     $$state[&IDX_S_handler_modes()] = [ ];
 68:     $$state[&IDX_S_handler_mode_stack()] = [ ];
 69:     $$state[&IDX_S_last_gen_name()] = 'aaa';
 70:     # define built in handler function references
 71:     $$state[&IDX_S_named_handlers()] = {
 72:         'process' => sub {
 73:             $_[0]->process_content;
 74:         },
 75:         'suppress' => sub {
 76:             $_[0]->suppress_content;
 77:         }
 78:     };
 79:     # finish object
 80:     $self = bless $self,$class;
 81:     # create base mode set
 82:     $self->mode_set_push('DEFAULT');
 83:     return $self;
 84: }

 86: # activate debugging/trace messages     
 87: sub debug {
 88:     my $self = shift;
 89:     if (@_ == 0) {
 90:         return $debug = 1;
 91:     }
 92:     my (@args) = map { lc } @_;
 93:     my ($ak,$k,$r,$v);
 94:     my %mode = ('general'  => \$debug,
 95:                 'modes' => \$debug_modes,
 96:                 'stack' => \$debug_stack,
 97:                 'element_path' => \$debug_elpath,
 98:                 'visitors' => \$debug_visit,
 99:                 'events' => \$debug_event,
100:                 'handler_lookup' => \$debug_lookup,
101:                 );
102:     foreach $k (@args) {
103:         $v = 1;
104:         if ($k =~ /^no_(.*)$/) {
105:             $k = $1;
106:             $v = 0;
107:         }
108:         if ($k eq 'all') {
109:             foreach $ak (keys %mode) {
110:                 $r = $mode{$ak};
111:                 $$r = $v;
112:             }
113:         } else {
114:             $r = $mode{$k};
115:             if (defined $r) {
116:                 $$r = $v;
117:             } else {
118:                 carp "'".$k."' not a valid debugging mode";
119:             }
120:         }
121:     }
122: }

124: # return or set the process driver module
125: sub driver {
126:     my ($self,$driver) = @_;
127:     my $old = $self->[&IDX_M_state()]->[&IDX_S_driver()];
128:     return $old unless defined $driver;

130:     if (!ref $driver) {
131:         croak "invalid driver object type '".$driver."'"
132:             if $driver =~ m/[^a-zA-Z_:]/;
133:         my $pkg = $driver;
134:         my $s = 0;
135:         ($s,$driver) = eval 'use '.$pkg.' (); (1, '.$pkg.'->new());';
136:         warn 'driver instantiation error: '.$@ unless defined $s;
137:         croak "Driver module ".$pkg." invalid (failed to create new object)"
138:             unless defined $driver;
139:     }
140:     croak "object ".ref($driver)." not a ".__PACKAGE__."::Driver object"
141:         unless $driver->isa(__PACKAGE__."::Driver");
142:     $self->[&IDX_M_state()]->[&IDX_S_driver()] = $driver;
143:     return $old;
144: }

146: # execute transformation on a grove object
147: sub process_grove {
148:     my ($self,$grove,@extra) = @_;
149:     my $driver = $self->[&IDX_M_state()]->[&IDX_S_driver()];
150:     if  (!ref($driver) ||   # assign default driver if necessary
151:          !$driver->isa(__PACKAGE__."::Driver::Grove")) {
152:         $self->driver(__PACKAGE__."::Driver::Grove");
153:         $driver = $self->[&IDX_M_state()]->[&IDX_S_driver()];
154:     }
155:     return $driver->process_grove($self,$grove,@extra);
156: }


159: # execute transformation on a file object
160: sub process_xml_file {
161:     my ($self,$file,@extra) = @_;
162:     my $driver = $self->[&IDX_M_state()]->[&IDX_S_driver()];
163:     if  (!ref($driver)) {   # assign default driver if necessary
164:         $self->driver(__PACKAGE__."::Driver::Grove");
165:         $driver = $self->[&IDX_M_state()]->[&IDX_S_driver()];
166:     }
167:     #$driver->markup('xml');
168:     #$driver->input('file');
169:     return $driver->process_xml_file($self,$file,@extra);
170: }

172: # execute transformation on a file object
173: sub process_sgml_file {
174:     my ($self,$file,@extra) = @_;
175:     my $driver = $self->[&IDX_M_state()]->[&IDX_S_driver()];
176:     if  (!ref($driver)) {   # assign default driver if necessary
177:         $self->driver(__PACKAGE__."::Driver::Grove");
178:         $driver = $self->[&IDX_M_state()]->[&IDX_S_driver()];
179:     }
180:     return $driver->process_sgml_file($self,$file,@extra);
181: }

183: # make a handler with special privileges, callable by id
184: # id is a name to use or null to create a name
185: #   id can be ref to a place to store an id
186: #   reusing a ref will replace the handler stored at that id
187: # privileges are things like control of stack layer creation, etc.
188: sub register {
189:     my ($self, $id, $code, @control_args) = @_;
190:     croak "Attempt to register something not a reference" unless ref $code;
191:     my $named = $self->[&IDX_M_state()]->[&IDX_S_named_handlers()];
192:     my ($loc);
193:     if (ref $id) {
194:         $loc = $id;
195:         $id = $$id;
196:     } else {
197:         $loc = '';
198:     }
199:     if (defined($id) && $id) {
200:         #remove_handler($id) if have_handler($id);
201:         $named->{$id} = '';
202:     } else {
203:         $id = '_' . $self->generate_name();
204:     }
205:     if (@control_args) {
206:         croak "register does not yet implement control arguments";
207:     }
208:     $$named{$id} = $code;
209:     $$loc = $id if $loc;
210:     return $id;
211: }

213: # generates a new name (unique within this object)
214: sub generate_name {
215:     my ($self) = @_;
216:     return ++$self->[&IDX_M_state()]->[&IDX_S_last_gen_name()];
217: }

219: # compile static analysis for given modes
220: # changes to finalized modes are ignored
221: sub finalize {
222:     my ($self,@modes) = @_;
223:     my $modeset = $self->[&IDX_M_modes()];
224:     @modes = keys(%$modeset) if (@modes == 0);
225:     @modes = map { if (ref $_) { $_ } else { $modeset->{$_}; } } @modes;
226:     return $self->_finalize(@modes);
227: }

229: # return the current context (useful for debugging)
230: # probably should not rely on this for real code
231: sub get_context {
232:     my ($self) = @_;
233:     return $self->[&IDX_M_state()]->[&IDX_M_driver()]->context_path();
234: }

236: ######################################################################
237: # Variable Stack operations

239: #access to the variable stack "hash"
240: sub stack () {
241:     return $_[0]->[&IDX_M_var_stack()];
242: }

244: #prepare for filter-style processing
245: sub filter_open {
246:     my $self = shift;
247:     return [] unless (@_ > 0);
248:     croak __PACKAGE__."::filter_open called with uneven number".
249:         " of arguments (".scalar(@_).")" if (scalar(@_) % 2 != 0);
250:     my $skip = 1;
251:     my @names = map {$skip= !$skip;  $skip? () : $_ } @_; #keep order
252:     my %vars = @_;
253:     my $stack = $self->stack;
254:     my $sid = $stack->push();
255:     $stack->set_layer('opaque');  # affect only this layer
256:     foreach my $var (@names) {
257:         $stack->{$var} = $vars{$var};
258:     }
259:     $stack->set_layer('transparent');  #hide rest of layer
260:     return [ $sid, @names ];
261: }

263: #retrieve results of filter-style processing
264: sub filter_close {
265:     my $self = shift;
266:     my $data = shift;
267:     croak "Value passed to filter_close is not return value of filter_open"
268:         unless (ref $data);
269:     return () unless (@$data > 0);
270:     my $fid = shift @$data;  #get id for filter layer
271:     my $varstack = $self->stack;
272:     my @vals = @{ $varstack }{@$data}; #convert names to values
273:     $varstack->pop($fid);
274:     return @vals;
275: }

277: ######################################################################
278: # Mode operations

280: sub mode_set {
281:     my ($self,@newmodes) = @_;
282:     my ($state,$modes,$cmodes,$mode,@oldmodes);
283:     $state = $$self[&IDX_M_state()];
284:     $modes = $$self[&IDX_M_modes()];
285:     $cmodes = $$state[&IDX_S_handler_modes()];
286:     @oldmodes = map { $$_{'_ MODENAME '} } @$cmodes;
287:     @$cmodes = ();
288:     foreach $mode (@newmodes) {
289:         if (!defined $$modes{$mode}) {
290:             warn "DBG:mode:Initializing new mode '$mode'\n" if $debug_modes;
291:             $$modes{$mode} = {'_ MODENAME ' => $mode,
292:                               '_ FINALIZE ' => '',
293:                               'Element' => {},
294:                               'SData'   => {},
295:                               'PI'      => {},
296:                               'CData'   => {},
297:                               'RE'      => {},
298:                               'SubDoc'  => {},
299:                               'Comment' => {},
300:                               'Entity'  => {} }
301:         }
302:         push @$cmodes,$$modes{$mode};
303:     }
304:     if ($debug_modes) {
305:         my @new = map { $$_{'_ MODENAME '} } @$cmodes;
306:         my $savestack = $$state[&IDX_S_handler_mode_stack()];
307:         warn "DBG:mode:".scalar(@$savestack).": (@oldmodes) => (@new)\n";
308:     }
309:     return @oldmodes;
310: }

312: #not handled efficiently
313: sub mode_push {
314:     my ($self,@newmodes) = @_;
315:     my $state = $$self[&IDX_M_state()];
316:     my $cmodes = $$state[&IDX_S_handler_modes()];
317:     my @oldmodes = map { $$_{'_ MODENAME '} } @$cmodes;
318:     $self->mode_set(@oldmodes,@newmodes);
319: }

321: #not handled efficiently
322: sub mode_pop {
323:     my ($self) = @_;
324:     my $state = $$self[&IDX_M_state()];
325:     my $cmodes = $$state[&IDX_S_handler_modes()];
326:     my @oldmodes = map { $$_{'_ MODENAME '} } @$cmodes;
327:     my $mode = pop @oldmodes;
328:     $self->mode_set(@oldmodes);
329:     return $mode;
330: }

332: sub mode_set_push {
333:     my ($self,@newmodes) = @_;
334:     my ($state,$savestack);
335:     $state = $$self[&IDX_M_state()];
336:     $$state[&IDX_S_handler_mode_stack()] = [ ] unless defined $$state[&IDX_S_handler_mode_stack()];
337:     $savestack = $$state[&IDX_S_handler_mode_stack()];
338:     push @$savestack,'';
339:     $$savestack[$#$savestack] = [$self->mode_set(@newmodes)];
340: }

342: sub mode_set_pop {
343:     my ($self,@modecheck) = @_;
344:     my ($state,$savestack,$oldmodes,@modes,$i);
345:     $state = $$self[&IDX_M_state()];
346:     $savestack = $$state[&IDX_S_handler_mode_stack()];
347:     $oldmodes = pop @$savestack;
348:     @modes = $self->mode_set(@$oldmodes);
349:     if (@modecheck > 0) {
350:         for ($i=0; $i < @modes; $i +=1) {
351:             last if $modecheck[$i] ne $modes[$i];
352:         }
353:         if ($i != @modes || $i != @modecheck) {
354:             croak __PACKAGE__." ERROR:handler_mode_pop:Attempt to pop".
355:                 " non-current mode set";
356:         }
357:     }
358:     return @modes;
359: }

361: ######################################################################
362: # Functions for use inside handler to process corresponding content

364: sub suppress_content {
365:     my $self = shift;
366:     my $driver = $self->[&IDX_M_state()]->[&IDX_S_driver()];
367:     return $driver->skip_subtrees;
368: }

370: sub process_content {
371:     my $self = shift;
372:     my $driver = $self->[&IDX_M_state()]->[&IDX_S_driver()];
373:     return $driver->dispatch_subtrees($self,'',@_);
374: }

376: sub process_content_select_prefix {
377:     my $self = shift;
378:     my $pat = shift;
379:     my $driver = $self->[&IDX_M_state()]->[&IDX_S_driver()];
380:     return $driver->dispatch_subtrees($self,$pat,@_);
381: }

383: sub process_content_filt { &process_content_filter; }
384: sub process_content_filter {
385:     my $self = shift;
386:     my ($tmp,$state,$element,$filter);
387:     $state = $$self[&IDX_M_state()];
388:     #----add specified variables
389:     $filter = $self->filter_open(@_);
390:     #----process content
391:     $self->process_content;
392:     #----get results for given variables
393:     return $self->filter_close($filter);
394: }

396: sub insert_pseudo_element {
397:     my $self = shift;
398:     my $driver = $self->[&IDX_M_state()]->[&IDX_S_driver()];
399:     $driver->reparent_subtrees(@_);
400:     return $self->process_content($self);
401: }

403: sub reprocess_pseudo_element {
404:     my $self = shift;
405:     my $driver = $self->[&IDX_M_state()]->[&IDX_S_driver()];
406:     $driver->reparent_current_subtree(@_);
407:     return $self->process_content($self);
408: }



412: ######################################################################
413: # handler install functions

415: sub xpath_handler {
416:     warn "xpath_handler called but not reliable: ".caller()."\n";
417:     my ($self,$xpath_exp,$handler) = @_;
418:     my @names = split '/', $xpath_exp;
419:     my $rooted = 0;
420:     $rooted = 1 if ($names[0] eq '');
421:     foreach my $name (@names) {
422:         if ($name eq '') {
423:             $name = '.*';
424:         }
425:     }
426:     $names[0] = '' if $rooted;
427:     my $re = join '/',@names;
428:     
429:     return $self->_install_handler_current_modes('Element',$re,$handler);
430: }

432: sub element {
433:     my ($self,@args) = @_;
434:     return $self->_install_handler_current_modes('Element',@args);
435: }

437: sub sdata {
438:     my ($self,@args) = @_;
439:     return $self->_install_handler_current_modes('SData',@args);
440: }

442: sub entity {
443:     my ($self,@args) = @_;
444:     return $self->_install_handler_current_modes('Entity',@args);
445: }

447: sub extentity {
448:     my ($self,@args) = @_;
449:     return $self->_install_handler_current_modes('Entity',@args);
450: }

452: sub subdoc {
453:     my ($self,@args) = @_;
454:     return $self->_install_handler_current_modes('SubDoc',@args);
455: }

457: sub pi {
458:     my ($self,@args) = @_;
459:     return $self->_install_handler_current_modes('PI',@args);
460: }

462: sub cdata {
463:     my ($self,@args) = @_;
464:     return $self->_install_handler_current_modes('CData',@args);
465: }

467: sub comment {
468:     my ($self,@args) = @_;
469:     return $self->_install_handler_current_modes('Comment',@args);
470: }

472: #sub conforming {
473: #    my ($self,@args) = @_;
474: #    carp "Attempt to install handler for deprecated event type 'conforming'";
475: #    return undef;
476: #}

478: #########################################################################
479: ###  Internal Functions
480: #########################################################################

482: #Handler Structure:
483: # hash array (key: identifier)
484: #   list (simple list)
485: #     list (pair)
486: #       environment-spec
487: #       handler

489: # installs a handler to all current modes
490: sub _install_handler_current_modes {
491:     my ($self,$handlerset,@args) = @_;
492:     my ($mode,$state,$res);
493:     $state = $$self[&IDX_M_state()];
494:     $res = 1;
495:     foreach $mode (@ {$$state[&IDX_S_handler_modes()]}) {
496:         $res = $res && $self->_install_handler($$mode{$handlerset},@args);
497:     }
498:     return $res;
499: }

501: # store the handler ref with its envspec and key
502: sub _install_handler {
503:     my $self = shift;
504:     my ($handlerhash,$key,$envspec,$handler,@envspecs);
505:     if (@_ == 3) { # catches calls to old 4 argument version
506:         ($handlerhash,$envspec,$handler) = @_;
507:     } else {
508:         croak "Wrong number of arguments passed to InstallHandler";
509:     }
510:     @envspecs = (ref $envspec) ? @$envspec : ($envspec);
511:     foreach $envspec (@envspecs) {
512:         ($key,$envspec) = split_envspec($envspec);
513:         # set the hash if it isnt defined
514:         $$handlerhash{$key} = [ ] unless defined $$handlerhash{$key};
515:         # later handlers override earlier ones
516:         unshift @ {$$handlerhash{$key}}, [ $envspec, $handler ];
517:     }
518:     return 1;
519: }

521: # convert a path to a regex that will match appropriately
522: sub split_envspec {
523:     my ($spec) = @_;
524:     return ('', '') if ($spec eq '');  # null string skips match test
525:     my ($key, $path, @p, $end, $in_skip);
526:     if ($spec =~ s!(/+)\Z!!) { $end = $1; } else { $end = ''; }
527:     @p = ('', split '/', $spec);
528:     push @p,(('') x length($end)); # split throws away empty trailing segments!
529:     if (@p != 2 && $p[1] eq '') {
530:         shift @p; shift @p; # looks a little odd: we are avoiding an unshift
531:     }
532:     $key = $p[$#p];
533:     if ($key eq '') { #note: use * here for cdata handlers to match "ELNAME/"
534:         $p[$#p] = '[^/]*'; # replace this in pattern but not in actual key
535:     }
536:     die 'complex target not implemented: '.$key."\n"
537:         if $key =~ m/[][.?*{}|\\]/;
538:     $path = '';
539:     $in_skip = 0;
540:     foreach (@p) {
541:         $path .= '/' unless $in_skip;
542:         if ($_ ne '') {
543:             $path .= $_;
544:             $in_skip = 0;
545:         } else {
546:             $path .= '(?:[^/]+/)*' unless $in_skip;
547:             $in_skip = 1;
548:         }
549:     }
550:     return ($key, $path);
551: }

553: # store the handler ref with its envspec and key
554: sub _install_handler_OLD {
555:     my $self = shift;
556:     my ($handlerhash,$key,$envspec,$handler,@envspecs,@keys);
557:     if (@_ == 3) {
558:         ($handlerhash,$key,$handler) = @_;
559:         $envspec = '';
560:     } elsif (@_ == 4) {
561:         ($handlerhash,$key,$envspec,$handler) = @_;
562:     } else {
563:         croak "Wrong number of arguments passed to InstallHandler";
564:     }
565:     @envspecs = (ref $envspec) ? @$envspec : ($envspec);
566:     @keys = (ref $key) ? @$key : ($key);
567:     foreach $key (@keys) {
568:         # set the hash if it isnt defined
569:         $$handlerhash{$key} = [ ] unless defined $$handlerhash{$key};
570:         foreach $envspec (@envspecs) {
571:             # later handlers override earlier ones
572:             unshift @ {$$handlerhash{$key}}, [ $envspec, $handler ];
573:         }
574:     }
575:     return 1;
576: }


579: # find the handler for $key and search for envspec match
580: sub _lookup_handler {
581:     my ($self,$hash,$key,$envspec) = @_;
582:     my ($handler,$handlerpair);

584:     $envspec = '' unless defined $envspec;
585:     $handler = undef;
586:     if (defined $$hash{$key}) {
587:         #scan list for matching environment
588:         foreach $handlerpair (@ {$$hash{$key}}) {
589:             if (defined $$handlerpair[0] && $$handlerpair[0] ne '') {
590:                 #check environment spec against current environment
591:                 if ($envspec =~ m/^$$handlerpair[0]$/) {
592:                     $handler = $$handlerpair[1];
593:                     warn "DBG:lookup:   found $handler for ".($key ne '' ? $key : '*default')." in $envspec\n" if $debug_lookup;
594:                     last;
595:                 }
596:             } else {
597:                 #no environment spec, so match
598:                 $handler = $$handlerpair[1];
599:                 warn "DBG:lookup:   found $handler for ".($key ne '' ? $key : '*default')."\n" if $debug_lookup;
600:                 last;
601:             }
602:         }
603:     }
604:     if (! defined $handler) {
605:         if ($key ne '') {
606:             #scan default handlers
607:             $handler = $self->_lookup_handler($hash,'',$envspec);
608:         } else {
609:             # oops, this IS the default handler scan
610:             warn "DBG:lookup:   no handler for $envspec\n" if $debug_lookup;
611:             $handler = undef;
612:         }
613:     }
614:     
615:     return $handler;
616: }           

618: # compile static analysis -- not much good yet
619: sub _finalize {
620:     my ($self,@modes) = @_;
621:     if ($debug_final) {
622:         use Data::Dumper;
623:         warn Dumper($self);
624:     }

626:     foreach my $mode (@modes) {
627:         warn "OPTIMIZING ".$mode->{'_ MODENAME '}."\n" if $debug_final;
628:         my @handler_list = ();
629:         my $code = ' sub {
630:     my ($type,$key,$envspec) = @_;
631:     $envspec = "" unless defined $envspec;';
632:         
633:         my $step1 = '';    # string for between iterations
634:         foreach my $event_type (reverse sort keys %$mode) {
635:             next if $event_type =~ /^_ /; # skip metadata keys
636:             my $type_hash = $mode->{$event_type};
637:             
638:             next unless (scalar(keys %$type_hash) > 0);

640:             if ($event_type ne '') {
641:                 $code .= '
642:       '.$step1.'if ($type eq "'.$event_type.'") { ';
643:             } else {
644:                 $code .= ' else' if ($step1 ne '');
645:                 $code .= ' { ';
646:             }
647:             #sort "" to end
648:             #    0 + (($a && $b && ($a cmp $b)) || ($a && -1) || ($b && 1)) 
649:             my $step3 = '';
650:             foreach my $event_key (reverse sort keys %$type_hash) {
651:                 my $block = '';    # save code to insert default first
652:                 my $default = '';  # index for default handler
653:                 my $pair_list = $$type_hash{$event_key};
654:                 next unless @$pair_list > 0;
655:                 if ($event_key ne '') {
656:                     $code .= '
657:           '.$step3.'if ($key eq "'.$event_key.'") { ';
658:                 } else {
659:                     #$code .= ' else' if ($step3 ne ''); # new block for deflt
660:                     $code .= ' { ';
661:                 }

663:                 my $step2 = '';
664:                 foreach my $handlerpair (@$pair_list) {
665:                     if (defined $$handlerpair[0] && $$handlerpair[0] ne '') {
666:                         #check environment spec against current environment
667:                         my $pat = $$handlerpair[0];
668:                         $pat =~ s:(^|[^\\])/:$1\\/:gs;
669:                         $block .= '
670:               '.$step2.'if ($envspec =~ m/\A'.$pat.'\Z/so) {';
671:                         push @handler_list, $$handlerpair[1];
672:                         $block .= '
673:                  return '.$#handler_list.';
674:              }';
675:                     } else {
676:                         # this is the first non-env handler
677:                         push @handler_list, $$handlerpair[1];
678:                         $default = $#handler_list;
679:                         $block .= '
680:              return '.$default.';';
681:                         last;
682:                     }
683:                     $step2 = ' els';
684:                 }
685:                 $code .= '
686:              return '.$default.' unless $envspec ne "";'
687:                  if ($default ne '') && @$pair_list > 1; #skip test if just def
688:                 $code .= $block . '
689:          }';
690:                 $step3 = ' els';
691:             }

693:             $code .= '
694:      }';
695:             $step1 = ' els';
696:         } # foreach $event_type (keys %$mode)
697:         
698:         $code .= '
699:      return undef;
700:  }';
701:         warn "CODE::".$mode->{'_ MODENAME '}."::".$code."\n" if $debug_final;
702:         $code = eval $code;
703:         if (defined $code && 'CODE' eq ref $code) {
704:             $mode->{"_ FINALIZE "} = [ $code, @handler_list ];
705:         } else {
706:             warn "CODE EVAL: $@";
707:         }
708:     }
709:     return 1;
710: }

712: # execute a handler
713: sub _call_handler {
714:     my $self = shift;
715:     my $handler = shift;
716:     my $data = shift;
717:     my (@result,$sid,$hok,$htype,@sargs);
718:     
719:     # do after-handler-choice-hook here

721:     $hok = defined($handler);
722:     $htype = $hok && ref($handler);
723:     if ($htype && $htype eq 'ARRAY') {
724:         ($handler,@sargs) = @$handler;
725:         $htype = ref($handler);
726:     }
727:     if ($htype) {
728:         $sid = $self->stack->push;
729:         @result = &$handler($self,$data,@sargs,@_);
730:         $self->stack->pop($sid);
731:     } elsif ($hok) {
732:         my $named = $self->[&IDX_M_state()]->[&IDX_S_named_handlers()];
733:         if (defined $$named{$handler}) {
734:             # named handlers can use stack variables
735:             $sid = $self->stack->push;
736:             @result = & {$$named{$handler}} ($self,$data,@sargs,@_);
737:             $self->stack->pop($sid);
738:         } else {
739:             warn "Named event handler '$handler' not defined\n";
740:             return (0);
741:         }
742:     } else {
743:         confess "$0: Internal error: undefined value passed to _call_handler";
744:         return (0);
745:     }
746:     if (@result == 1 && !defined($result[0])) {
747:         warn "event handler returned undef or (undef): substituting ".
748:             "empty list.\n" if $^W;
749:         @result = ();
750:     }
751:     return (1,@result);
752: }

754: # take an event, pick and send it to a handler
755: sub _dispatch_event {
756:     my ($self,$type,$key,$data,@extraargs) = @_;
757:     warn "DBG:event:dispatch:$type:$key\n" if $debug_event;
758:     my ($handler,$mode,@results,$ok);
759:     my $state = $$self[&IDX_M_state()];
760:     my $driver = $state->[&IDX_S_driver()];
761:     # make context into a simple object path
762:     my $context_path = $driver->context_path;
763:     warn "DBG:context:".$context_path."\n" if $debug_elpath;
764:     # find and executer handler
765:     foreach $mode (@ {$$state[&IDX_S_handler_modes()]}) {
766:         warn "DBG:lookup:looking for ".$type." handler in ".
767:             $$mode{"_ MODENAME "}."\n" if $debug_lookup;
768:         if (ref($handler = $$mode{"_ FINALIZE "})) { # use static lookup
769:             my $code = $$handler[0];
770:             my $index = &$code($type, $key, $context_path);
771:             if (defined $index) {
772:                 $handler = $$handler[1+$index]; # +1 to skip over code
773:             } else {
774:                 undef $handler;
775:             }
776:         } else { # use plain lookup
777:             $handler = $self->_lookup_handler($$mode{$type}, $key,
778:                                               $context_path);
779:         }
780:         # if found handler, call it and end search
781:         if (defined $handler) {
782:             ($ok,@results) = $self->_call_handler($handler,$data,@extraargs);
783:             last;
784:         }
785:     }
786:     if (!defined $handler) {
787:         warn "No handler for $type event ('$key' ".ref($data).")!\n" if $^W;
788:         $driver->skip_subtrees;
789:         #if (!defined $self->CallHandler('suppress',$data,@extraargs)) {
790:         #    die "Handler call of 'suppress' on $type:'$key' event failed--";
791:         #}
792:     } elsif (! $ok) {
793:         warn "Handler call on $type event ('$key') failed!\n";
794:         $driver->skip_subtrees;
795:     }
796:     
797:     #sanity check
798:     if ($context_path ne $driver->context_path) {
799:         warn "ERROR:Internal inconsistency encountered:children did not restore current element. processing is probably inconsitent.\n";
800:     }
801:     
802:     return @results;
803: }


806: 1;