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;