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;