Node.pm
Go to the documentation of this file.
00001 #============================================================= -*-Perl-*- 00002 # 00003 # Pod::POM::Node 00004 # 00005 # DESCRIPTION 00006 # Base class for a node in a Pod::POM tree. 00007 # 00008 # AUTHOR 00009 # Andy Wardley <abw@wardley.org> 00010 # 00011 # COPYRIGHT 00012 # Copyright (C) 2000-2003 Andy Wardley. All Rights Reserved. 00013 # 00014 # This module is free software; you can redistribute it and/or 00015 # modify it under the same terms as Perl itself. 00016 # 00017 # REVISION 00018 # $Id: Node.pm 88 2010-04-02 13:37:41Z ford $ 00019 # 00020 #======================================================================== 00021 00022 package BASIS::Pod::POM::Node; 00023 00024 require 5.004; 00025 00026 use strict; 00027 use BASIS::Pod::POM::Nodes; 00028 use BASIS::Pod::POM::Constants qw( :all ); 00029 use vars qw( $VERSION $DEBUG $ERROR $NODES $NAMES $AUTOLOAD ); 00030 use constant DUMP_LINE_LENGTH => 80; 00031 00032 $VERSION = sprintf("%d.%02d", q$Revision: 1.5 $ =~ /(\d+)\.(\d+)/); 00033 $DEBUG = 0 unless defined $DEBUG; 00034 $NODES = { 00035 pod => 'BASIS::Pod::POM::Node::Pod', 00036 head1 => 'BASIS::Pod::POM::Node::Head1', 00037 head2 => 'BASIS::Pod::POM::Node::Head2', 00038 head3 => 'BASIS::Pod::POM::Node::Head3', 00039 head4 => 'BASIS::Pod::POM::Node::Head4', 00040 over => 'BASIS::Pod::POM::Node::Over', 00041 item => 'BASIS::Pod::POM::Node::Item', 00042 begin => 'BASIS::Pod::POM::Node::Begin', 00043 for => 'BASIS::Pod::POM::Node::For', 00044 text => 'BASIS::Pod::POM::Node::Text', 00045 code => 'BASIS::Pod::POM::Node::Code', 00046 verbatim => 'BASIS::Pod::POM::Node::Verbatim', 00047 }; 00048 $NAMES = { 00049 map { ( $NODES->{ $_ } => $_ ) } keys %$NODES, 00050 }; 00051 00052 # overload stringification to present node via a view 00053 use overload 00054 '""' => 'present', 00055 fallback => 1, 00056 'bool' => sub { 1 }; 00057 00058 # alias meta() to metadata() 00059 *meta = \*metadata; 00060 00061 00062 #------------------------------------------------------------------------ 00063 # new($pom, @attr) 00064 # 00065 # Constructor method. Returns a new Pod::POM::Node::* object or undef 00066 # on error. First argument is the Pod::POM parser object, remaining 00067 # arguments are node attributes as specified in %ATTRIBS in derived class 00068 # package. 00069 #------------------------------------------------------------------------ 00070 00071 sub new { 00072 my $class = shift; 00073 my $pom = shift; 00074 my ($type, $attribs, $accept, $key, $value, $default); 00075 00076 $type = $NAMES->{ $class }; 00077 00078 { 00079 no strict qw( refs ); 00080 $attribs = \%{"$class\::ATTRIBS"} || [ ]; 00081 $accept = \@{"$class\::ACCEPT"} || [ ]; 00082 unless (%{"$class\::ACCEPT"}) { 00083 %{"$class\::ACCEPT"} = ( 00084 map { ( $_ => $NODES->{ $_ } ) } @$accept, 00085 ); 00086 } 00087 } 00088 00089 # create object with slots for each acceptable child and overall content 00090 my $self = bless { 00091 type => $type, 00092 content => bless([ ], 'BASIS::Pod::POM::Node::Content'), 00093 map { ($_ => bless([ ], 'BASIS::Pod::POM::Node::Content')) } 00094 (@$accept, 'code'), 00095 }, $class; 00096 00097 # set attributes from arguments 00098 keys %$attribs; # reset hash iterator 00099 while(my ($key, $default) = each %$attribs) { 00100 $value = shift || $default; 00101 return $class->error("$type expected a $key") 00102 unless $value; 00103 $self->{ $key } = $value; 00104 } 00105 00106 return $self; 00107 } 00108 00109 00110 #------------------------------------------------------------------------ 00111 # add($pom, $type, @attr) 00112 # 00113 # Adds a new node as a child element (content) of the current node. 00114 # First argument is the Pod::POM parser object. Second argument is the 00115 # child node type specified by name (e.g. 'head1') which is mapped via 00116 # the $NODES hash to a class name against which new() can be called. 00117 # Remaining arguments are attributes passed to the child node constructor. 00118 # Returns a reference to the new node (child was accepted) or one of the 00119 # constants REDUCE (child terminated node, e.g. '=back' terminates an 00120 # '=over' node), REJECT (child rejected, e.g. '=back' expected to terminate 00121 # '=over' but something else found instead) or IGNORE (node didn't expect 00122 # child and is implicitly terminated). 00123 #------------------------------------------------------------------------ 00124 00125 sub add { 00126 my $self = shift; 00127 my $pom = shift; 00128 my $type = shift; 00129 my $class = ref $self; 00130 my ($name, $attribs, $accept, $expect, $nodeclass, $node); 00131 00132 $name = $NAMES->{ $class } 00133 || return $self->error("no name for $class"); 00134 { 00135 no strict qw( refs ); 00136 $accept = \%{"$class\::ACCEPT"}; 00137 $expect = ${"$class\::EXPECT"}; 00138 } 00139 00140 # SHIFT: accept indicates child nodes that can be accepted; a 00141 # new node is created, added it to content list and node specific 00142 # list, then returned by reference. 00143 00144 if ($nodeclass = $accept->{ $type }) { 00145 defined($node = $nodeclass->new($pom, @_)) 00146 || return $self->error($nodeclass->error()) 00147 unless defined $node; 00148 push(@{ $self->{ $type } }, $node); 00149 push(@{ $self->{ content } }, $node); 00150 $pom->{in_begin} = 1 if $nodeclass eq 'BASIS::Pod::POM::Node::Begin'; 00151 return $node; 00152 } 00153 00154 # REDUCE: expect indicates the token that should terminate this node 00155 if (defined $expect && ($type eq $expect)) { 00156 DEBUG("$name terminated by expected $type\n"); 00157 $pom->{in_begin} = 0 if $name eq 'begin'; 00158 return REDUCE; 00159 } 00160 00161 # REJECT: expected terminating node was not found 00162 if (defined $expect) { 00163 DEBUG("$name rejecting $type, expecting a terminating $expect\n"); 00164 $self->error("$name expected a terminating $expect"); 00165 return REJECT; 00166 } 00167 00168 # IGNORE: don't know anything about this node 00169 DEBUG("$name ignoring $type\n"); 00170 return IGNORE; 00171 } 00172 00173 00174 #------------------------------------------------------------------------ 00175 # present($view) 00176 # 00177 # Present the node by making a callback on the appropriate method against 00178 # the view object passed as an argument. $Pod::POM::DEFAULT_VIEW is used 00179 # if $view is unspecified. 00180 #------------------------------------------------------------------------ 00181 00182 sub present { 00183 my ($self, $view, @args) = @_; 00184 $view ||= $BASIS::Pod::POM::DEFAULT_VIEW; 00185 my $type = $self->{ type }; 00186 my $method = "view_$type"; 00187 DEBUG("presenting method $method to $view\n"); 00188 my $txt = $view->$method($self, @args); 00189 if ($view->can("encode")){ 00190 return $view->encode($txt); 00191 } else { 00192 return $txt; 00193 } 00194 } 00195 00196 00197 #------------------------------------------------------------------------ 00198 # metadata() 00199 # metadata($key) 00200 # metadata($key, $value) 00201 # 00202 # Returns the metadata hash when called without any arguments. Returns 00203 # the value of a metadata item when called with a single argument. 00204 # Sets a metadata item to a value when called with two arguments. 00205 #------------------------------------------------------------------------ 00206 00207 sub metadata { 00208 my ($self, $key, $value) = @_; 00209 my $metadata = $self->{ METADATA } ||= { }; 00210 00211 return $metadata unless defined $key; 00212 00213 if (defined $value) { 00214 $metadata->{ $key } = $value; 00215 } 00216 else { 00217 $value = $self->{ METADATA }->{ $key }; 00218 return defined $value ? $value 00219 : $self->error("no such metadata item: $key"); 00220 } 00221 } 00222 00223 00224 #------------------------------------------------------------------------ 00225 # error() 00226 # error($msg, ...) 00227 # 00228 # May be called as a class or object method to set or retrieve the 00229 # package variable $ERROR (class method) or internal member 00230 # $self->{ _ERROR } (object method). The presence of parameters indicates 00231 # that the error value should be set. Undef is then returned. In the 00232 # abscence of parameters, the current error value is returned. 00233 #------------------------------------------------------------------------ 00234 00235 sub error { 00236 my $self = shift; 00237 my $errvar; 00238 # use Carp; 00239 00240 { 00241 no strict qw( refs ); 00242 if (ref $self) { 00243 # my ($pkg, $file, $line) = caller(); 00244 # print STDERR "called from $file line $line\n"; 00245 # croak "cannot get/set error in non-hash: $self\n" 00246 # unless UNIVERSAL::isa($self, 'HASH'); 00247 $errvar = \$self->{ ERROR }; 00248 } 00249 else { 00250 $errvar = \${"$self\::ERROR"}; 00251 } 00252 } 00253 if (@_) { 00254 $$errvar = ref($_[0]) ? shift : join('', @_); 00255 return undef; 00256 } 00257 else { 00258 return $$errvar; 00259 } 00260 } 00261 00262 00263 #------------------------------------------------------------------------ 00264 # dump() 00265 # 00266 # Returns a representation of the element and all its children in a 00267 # format useful only for debugging. The structure of the document is 00268 # shown by indentation (inspired by HTML::Element). 00269 #------------------------------------------------------------------------ 00270 00271 sub dump { 00272 my($self, $depth) = @_; 00273 my $output; 00274 $depth = 0 unless defined $depth; 00275 my $nodepkg = ref $self; 00276 if ($self->isa('REF')) { 00277 $self = $$self; 00278 my $cmd = $self->[CMD]; 00279 my @content = @{ $self->[CONTENT] }; 00280 if ($cmd) { 00281 $output .= (" " x $depth) . $cmd . $self->[LPAREN] . "\n"; 00282 } 00283 foreach my $item (@content) { 00284 if (ref $item) { 00285 $output .= $item->dump($depth+1); # recurse 00286 } 00287 else { # text node 00288 $output .= _dump_text($item, $depth+1); 00289 } 00290 } 00291 if ($cmd) { 00292 $output .= (" " x $depth) . $self->[RPAREN] . "\n", ; 00293 } 00294 } 00295 else { 00296 no strict 'refs'; 00297 my @attrs = sort keys %{"*${nodepkg}::ATTRIBS"}; 00298 $output .= (" " x $depth) . $self->type . "\n"; 00299 foreach my $attr (@attrs) { 00300 if (my $value = $self->{$attr}) { 00301 $output .= (" " x ($depth+1)) . "\@$attr\n"; 00302 00303 if (ref $value) { 00304 $output .= $value->dump($depth+1); 00305 } 00306 else { 00307 $output .= _dump_text($value, $depth+2); 00308 } 00309 } 00310 } 00311 foreach my $item (@{$self->{content}}) { 00312 if (ref $item) { # element 00313 $output .= $item->dump($depth+1); # recurse 00314 } 00315 else { # text node 00316 $output .= _dump_text($item, $depth+1); 00317 } 00318 } 00319 } 00320 00321 return $output; 00322 } 00323 00324 sub _dump_text { 00325 my ($text, $depth) = @_; 00326 00327 my $output = ""; 00328 my $padding = " " x $depth; 00329 my $max_text_len = DUMP_LINE_LENGTH - length($depth) - 2; 00330 00331 foreach my $line (split(/\n/, $text)) { 00332 $output .= $padding; 00333 if (length($line) > $max_text_len or $line =~ m<[\x00-\x1F]>) { 00334 # it needs prettyin' up somehow or other 00335 my $x = (length($line) <= $max_text_len) ? $_ : (substr($line, 0, $max_text_len) . '...'); 00336 $x =~ s<([\x00-\x1F])> 00337 <'\\x'.(unpack("H2",$1))>eg; 00338 $output .= qq{"$x"\n}; 00339 } else { 00340 $output .= qq{"$line"\n}; 00341 } 00342 } 00343 return $output; 00344 } 00345 00346 00347 #------------------------------------------------------------------------ 00348 # AUTOLOAD 00349 #------------------------------------------------------------------------ 00350 00351 sub AUTOLOAD { 00352 my $self = shift; 00353 my $name = $AUTOLOAD; 00354 my $item; 00355 00356 $name =~ s/.*:://; 00357 return if $name eq 'DESTROY'; 00358 00359 # my ($pkg, $file, $line) = caller(); 00360 # print STDERR "called from $file line $line to return ", ref($item), "\n"; 00361 00362 return $self->error("can't manipulate \$self") 00363 unless UNIVERSAL::isa($self, 'HASH'); 00364 return $self->error("no such member: $name") 00365 unless defined ($item = $self->{ $name }); 00366 00367 return wantarray ? ( UNIVERSAL::isa($item, 'ARRAY') ? @$item : $item ) 00368 : $item; 00369 } 00370 00371 00372 #------------------------------------------------------------------------ 00373 # DEBUG(@msg) 00374 #------------------------------------------------------------------------ 00375 00376 sub DEBUG { 00377 print STDERR "DEBUG: ", @_ if $DEBUG; 00378 } 00379 00380 1; 00381 00382 00383 00384 =head1 NAME 00385 00386 Pod::POM::Node - base class for a POM node 00387 00388 =head1 SYNOPSIS 00389 00390 package Pod::POM::Node::Over; 00391 use base qw( Pod::POM::Node ); 00392 use vars qw( %ATTRIBS @ACCEPT $EXPECT $ERROR ); 00393 00394 %ATTRIBS = ( indent => 4 ); 00395 @ACCEPT = qw( over item begin for text verbatim ); 00396 $EXPECT = q( back ); 00397 00398 package main; 00399 my $list = Pod::POM::Node::Over->new(8); 00400 $list->add('item', 'First Item'); 00401 $list->add('item', 'Second Item'); 00402 ... 00403 00404 =head1 DESCRIPTION 00405 00406 This documentation describes the inner workings of the Pod::POM::Node 00407 module and gives a brief overview of the relationship between it and 00408 its derived classes. It is intended more as a guide to the internals 00409 for interested hackers than as general user documentation. See 00410 L<Pod::POM> for information on using the modules. 00411 00412 This module implements a base class node which is subclassed to 00413 represent different elements within a Pod Object Model. 00414 00415 package Pod::POM::Node::Over; 00416 use base qw( Pod::POM::Node ); 00417 00418 The base class implements the new() constructor method to instantiate 00419 new node objects. 00420 00421 my $list = Pod::POM::Node::Over->new(); 00422 00423 The characteristics of a node can be specified by defining certain 00424 variables in the derived class package. The C<%ATTRIBS> hash can be 00425 used to denote attributes that the node should accept. In the case of 00426 an C<=over> node, for example, an C<indent> attribute can be specified 00427 which otherwise defaults to 4. 00428 00429 package Pod::POM::Node::Over; 00430 use base qw( Pod::POM::Node ); 00431 use vars qw( %ATTRIBS $ERROR ); 00432 00433 %ATTRIBS = ( indent => 4 ); 00434 00435 The new() method will now expect an argument to set the indent value, 00436 or will use 4 as the default if no argument is provided. 00437 00438 my $list = Pod::POM::Node::Over->new(8); # indent: 8 00439 my $list = Pod::POM::Node::Over->new( ); # indent: 4 00440 00441 If the default value is undefined then the argument is mandatory. 00442 00443 package Pod::POM::Node::Head1; 00444 use base qw( Pod::POM::Node ); 00445 use vars qw( %ATTRIBS $ERROR ); 00446 00447 %ATTRIBS = ( title => undef ); 00448 00449 package main; 00450 my $head = Pod::POM::Node::Head1->new('My Title'); 00451 00452 If a mandatory argument isn't provided then the constructor will 00453 return undef to indicate failure. The $ERROR variable in the derived 00454 class package is set to contain a string of the form "$type expected a 00455 $attribute". 00456 00457 # dies with error: "head1 expected a title" 00458 my $head = Pod::POM::Node::Head1->new() 00459 || die $Pod::POM::Node::Head1::ERROR; 00460 00461 For convenience, the error() subroutine can be called as a class 00462 method to retrieve this value. 00463 00464 my $type = 'Pod::POM::Node::Head1'; 00465 my $head = $type->new() 00466 || die $type->error(); 00467 00468 The C<@ACCEPT> package variable can be used to indicate the node types 00469 that are permitted as children of a node. 00470 00471 package Pod::POM::Node::Head1; 00472 use base qw( Pod::POM::Node ); 00473 use vars qw( %ATTRIBS @ACCEPT $ERROR ); 00474 00475 %ATTRIBS = ( title => undef ); 00476 @ACCEPT = qw( head2 over begin for text verbatim ); 00477 00478 The add() method can then be called against a node to add a new child 00479 node as part of its content. 00480 00481 $head->add('over', 8); 00482 00483 The first argument indicates the node type. The C<@ACCEPT> list is 00484 examined to ensure that the child node type is acceptable for the 00485 parent node. If valid, the constructor for the relevant child node 00486 class is called passing any remaining arguments as attributes. The 00487 new node is then returned. 00488 00489 my $list = $head->add('over', 8); 00490 00491 The error() method can be called against the I<parent> node to retrieve 00492 any constructor error generated by the I<child> node. 00493 00494 my $list = $head->add('over', 8); 00495 die $head->error() unless defined $list; 00496 00497 If the child node is not acceptable to the parent then the add() 00498 method returns one of the constants IGNORE, REDUCE or REJECT, as 00499 defined in Pod::POM::Constants. These return values are used by the 00500 Pod::POM parser module to implement a simple shift/reduce parser. 00501 00502 In the most common case, IGNORE is returned to indicate that the 00503 parent node doesn't know anything about the new child node. The 00504 parser uses this as an indication that it should back up through the 00505 parse stack until it finds a node which I<will> accept this child node. 00506 Through this mechanism, the parser is able to implicitly terminate 00507 certain POD blocks. For example, a list item initiated by a C<=item> 00508 tag will I<not> accept another C<=item> tag, but will instead return IGNORE. 00509 The parser will back out until it finds the enclosing C<=over> node 00510 which I<will> accept it. Thus, a new C<=item> implicitly terminates any 00511 previous C<=item>. 00512 00513 The C<$EXPECT> package variable can be used to indicate a node type 00514 which a parent expects to terminate itself. An C<=over> node, for 00515 example, should always be terminated by a matching C<=back>. When 00516 such a match is made, the add() method returns REDUCE to indicate 00517 successful termination. 00518 00519 package Pod::POM::Node::Over; 00520 use base qw( Pod::POM::Node ); 00521 use vars qw( %ATTRIBS @ACCEPT $EXPECT $ERROR ); 00522 00523 %ATTRIBS = ( indent => 4 ); 00524 @ACCEPT = qw( over item begin for text verbatim ); 00525 $EXPECT = q( back ); 00526 00527 package main; 00528 my $list = Pod::POM::Node::Over->new(); 00529 my $item = $list->add('item'); 00530 $list->add('back'); # returns REDUCE 00531 00532 If a child node isn't specified in the C<@ACCEPT> list or doesn't match 00533 any C<$EXPECT> specified then REJECT is returned. The parent node sets 00534 an internal error of the form "$type expected a terminating $expect". 00535 The parser uses this to detect missing POD tags. In nearly all cases 00536 the parser is smart enough to fix the incorrect structure and downgrades 00537 any errors to warnings. 00538 00539 # dies with error 'over expected terminating back' 00540 ref $list->add('head1', 'My Title') # returns REJECT 00541 || die $list->error(); 00542 00543 Each node contains a 'type' field which contains a simple string 00544 indicating the node type, e.g. 'head1', 'over', etc. The $NODES and 00545 $NAMES package variables (in the base class) reference hash arrays 00546 which map these names to and from package names (e.g. head1 E<lt>=E<gt> 00547 Pod::POM::Node::Head1). 00548 00549 print $list->{ type }; # 'over' 00550 00551 An AUTOLOAD method is provided to access to such internal items for 00552 those who don't like violating an object's encapsulation. 00553 00554 print $list->type(); 00555 00556 Nodes also contain a 'content' list, blessed into the 00557 Pod::POM::Node::Content class, which contains the content (child 00558 elements) for the node. The AUTOLOAD method returns this as a list 00559 reference or as a list of items depending on the context in which it 00560 is called. 00561 00562 my $items = $list->content(); 00563 my @items = $list->content(); 00564 00565 Each node also contains a content list for each individual child node 00566 type that it may accept. 00567 00568 my @items = $list->item(); 00569 my @text = $list->text(); 00570 my @vtext = $list->verbatim(); 00571 00572 The present() method is used to present a node through a particular view. 00573 This simply maps the node type to a method which is then called against the 00574 view object. This is known as 'double dispatch'. 00575 00576 my $view = 'Pod::POM::View::HTML'; 00577 print $list->present($view); 00578 00579 The method name is constructed from the node type prefixed by 'view_'. 00580 Thus the following are roughly equivalent. 00581 00582 $list->present($view); 00583 00584 $view->view_list($list); 00585 00586 The benefit of the former over the latter is, of course, that the 00587 caller doesn't need to know or determine the type of the node. The 00588 node itself is in the best position to determine what type it is. 00589 00590 =head1 AUTHOR 00591 00592 Andy Wardley E<lt>abw@kfs.orgE<gt> 00593 00594 =head1 COPYRIGHT 00595 00596 Copyright (C) 2000, 2001 Andy Wardley. All Rights Reserved. 00597 00598 This module is free software; you can redistribute it and/or 00599 modify it under the same terms as Perl itself. 00600 00601 =head1 SEE ALSO 00602 00603 Consult L<Pod::POM> for a general overview and examples of use. 00604