local-lib5/lib/perl5/PPI/Element.pm

   1 package PPI::Element;
   2
   3 =pod
   4
   5 =head1 NAME
   6
   7 PPI::Element - The abstract Element class, a base for all source objects
   8
   9 =head1 INHERITANCE
  10
  11   PPI::Element is the root of the PDOM tree
  12
  13 =head1 DESCRIPTION
  14
  15 The abstract C<PPI::Element> serves as a base class for all source-related
  16 objects, from a single whitespace token to an entire document. It provides
  17 a basic set of methods to provide a common interface and basic
  18 implementations.
  19
  20 =head1 METHODS
  21
  22 =cut
  23
  24 use strict;
  25 use Clone           ();
  26 use Scalar::Util    qw{refaddr};
  27 use Params::Util    qw{_INSTANCE _ARRAY};
  28 use List::MoreUtils ();
  29 use PPI::Util       ();
  30 use PPI::Node       ();
  31
  32 use vars qw{$VERSION $errstr %_PARENT};
  33 BEGIN {
  34         $VERSION = '1.206';
  35         $errstr  = '';
  36
  37         # Master Child -> Parent index
  38         %_PARENT = ();
  39 }
  40
  41 use overload 'bool' => \&PPI::Util::TRUE;
  42 use overload '""'   => 'content';
  43 use overload '=='   => '__equals';
  44 use overload '!='   => '__nequals';
  45 use overload 'eq'   => '__eq';
  46 use overload 'ne'   => '__ne';
  47
  48
  49
  50
  51
  52 #####################################################################
  53 # General Properties
  54
  55 =pod
  56
  57 =head2 significant
  58
  59 Because we treat whitespace and other non-code items as Tokens (in order to
  60 be able to "round trip" the L<PPI::Document> back to a file) the
  61 C<significant> method allows us to distinguish between tokens that form a
  62 part of the code, and tokens that aren't significant, such as whitespace,
  63 POD, or the portion of a file after (and including) the C<__END__> token.
  64
  65 Returns true if the Element is significant, or false it not.
  66
  67 =cut
  68
  69 ### XS -> PPI/XS.xs:_PPI_Element__significant 0.845+
  70 sub significant { 1 }
  71
  72 =pod
  73
  74 =head2 class
  75
  76 The C<class> method is provided as a convenience, and really does nothing
  77 more than returning C<ref($self)>. However, some people have found that
  78 they appreciate the laziness of C<$Foo-E<gt>class eq 'whatever'>, so I
  79 have caved to popular demand and included it.
  80
  81 Returns the class of the Element as a string
  82
  83 =cut
  84
  85 sub class { ref($_[0]) }
  86
  87 =pod
  88
  89 =head2 tokens
  90
  91 The C<tokens> method returns a list of L<PPI::Token> objects for the
  92 Element, essentially getting back that part of the document as if it had
  93 not been lexed.
  94
  95 This also means there are no Statements and no Structures in the list,
  96 just the Token classes.
  97
  98 =cut
  99
 100 sub tokens { $_[0] }
 101
 102 =pod
 103
 104 =head2 content
 105
 106 For B<any> C<PPI::Element>, the C<content> method will reconstitute the
 107 base code for it as a single string. This method is also the method used
 108 for overloading stringification. When an Element is used in a double-quoted
 109 string for example, this is the method that is called.
 110
 111 B<WARNING:>
 112
 113 You should be aware that because of the way that here-docs are handled, any
 114 here-doc content is not included in C<content>, and as such you should
 115 B<not> eval or execute the result if it contains any L<PPI::Token::HereDoc>.
 116
 117 The L<PPI::Document> method C<serialize> should be used to stringify a PDOM
 118 document into something that can be executed as expected.
 119
 120 Returns the basic code as a string (excluding here-doc content).
 121
 122 =cut
 123
 124 ### XS -> PPI/XS.xs:_PPI_Element__content 0.900+
 125 sub content { '' }
 126
 127
 128
 129
 130
 131 #####################################################################
 132 # Naigation Methods
 133
 134 =pod
 135
 136 =head2 parent
 137
 138 Elements themselves are not intended to contain other Elements, that is
 139 left to the L<PPI::Node> abstract class, a subclass of C<PPI::Element>.
 140 However, all Elements can be contained B<within> a parent Node.
 141
 142 If an Element is within a parent Node, the C<parent> method returns the
 143 Node.
 144
 145 =cut
 146
 147 sub parent { $_PARENT{refaddr $_[0]} }
 148
 149 =pod
 150
 151 =head2 descendant_of $element
 152
 153 Answers whether a C<PPI::Element> is contained within another one.
 154
 155 C<PPI::Element>s are considered to be descendants of themselves.
 156
 157 =begin testing descendant_of 9
 158
 159 my $Document = PPI::Document->new( \'( [ thingy ] ); $blarg = 1' );
 160 isa_ok( $Document, 'PPI::Document' );
 161 ok(
 162         $Document->descendant_of($Document),
 163         'Document is a descendant of itself.',
 164 );
 165
 166 my $words = $Document->find('Token::Word');
 167 is(scalar @{$words}, 1, 'Document contains 1 Word.');
 168 my $word = $words->[0];
 169 ok(
 170         $word->descendant_of($word),
 171         'Word is a descendant of itself.',
 172 );
 173 ok(
 174         $word->descendant_of($Document),
 175         'Word is a descendant of the Document.',
 176 );
 177 ok(
 178         ! $Document->descendant_of($word),
 179         'Document is not a descendant of the Word.',
 180 );
 181
 182 my $symbols = $Document->find('Token::Symbol');
 183 is(scalar @{$symbols}, 1, 'Document contains 1 Symbol.');
 184 my $symbol = $symbols->[0];
 185 ok(
 186         ! $word->descendant_of($symbol),
 187         'Word is not a descendant the Symbol.',
 188 );
 189 ok(
 190         ! $symbol->descendant_of($word),
 191         'Symbol is not a descendant the Word.',
 192 );
 193
 194 =end testing
 195
 196 =cut
 197
 198 sub descendant_of {
 199         my $cursor = shift;
 200         my $parent = shift or return undef;
 201         while ( refaddr $cursor != refaddr $parent ) {
 202                 $cursor = $_PARENT{refaddr $cursor} or return '';
 203         }
 204         return 1;
 205 }
 206
 207 =pod
 208
 209 =head2 ancestor_of $element
 210
 211 Answers whether a C<PPI::Element> is contains another one.
 212
 213 C<PPI::Element>s are considered to be ancestors of themselves.
 214
 215 =begin testing ancestor_of 9
 216
 217 my $Document = PPI::Document->new( \'( [ thingy ] ); $blarg = 1' );
 218 isa_ok( $Document, 'PPI::Document' );
 219 ok(
 220         $Document->ancestor_of($Document),
 221         'Document is an ancestor of itself.',
 222 );
 223
 224 my $words = $Document->find('Token::Word');
 225 is(scalar @{$words}, 1, 'Document contains 1 Word.');
 226 my $word = $words->[0];
 227 ok(
 228         $word->ancestor_of($word),
 229         'Word is an ancestor of itself.',
 230 );
 231 ok(
 232         ! $word->ancestor_of($Document),
 233         'Word is not an ancestor of the Document.',
 234 );
 235 ok(
 236         $Document->ancestor_of($word),
 237         'Document is an ancestor of the Word.',
 238 );
 239
 240 my $symbols = $Document->find('Token::Symbol');
 241 is(scalar @{$symbols}, 1, 'Document contains 1 Symbol.');
 242 my $symbol = $symbols->[0];
 243 ok(
 244         ! $word->ancestor_of($symbol),
 245         'Word is not an ancestor the Symbol.',
 246 );
 247 ok(
 248         ! $symbol->ancestor_of($word),
 249         'Symbol is not an ancestor the Word.',
 250 );
 251
 252 =end testing
 253
 254 =cut
 255
 256 sub ancestor_of {
 257         my $self   = shift;
 258         my $cursor = shift or return undef;
 259         while ( refaddr $cursor != refaddr $self ) {
 260                 $cursor = $_PARENT{refaddr $cursor} or return '';
 261         }
 262         return 1;
 263 }
 264
 265 =pod
 266
 267 =head2 statement
 268
 269 For a C<PPI::Element> that is contained (at some depth) within a
 270 L<PPI::Statment>, the C<statement> method will return the first parent
 271 Statement object lexically 'above' the Element.
 272
 273 Returns a L<PPI::Statement> object, which may be the same Element if the
 274 Element is itself a L<PPI::Statement> object.
 275
 276 Returns false if the Element is not within a Statement and is not itself
 277 a Statement.
 278
 279 =cut
 280
 281 sub statement {
 282         my $cursor = shift;
 283         while ( ! _INSTANCE($cursor, 'PPI::Statement') ) {
 284                 $cursor = $_PARENT{refaddr $cursor} or return '';
 285         }
 286         $cursor;
 287 }
 288
 289 =pod
 290
 291 =head2 top
 292
 293 For a C<PPI::Element> that is contained within a PDOM tree, the C<top> method
 294 will return the top-level Node in the tree. Most of the time this should be
 295 a L<PPI::Document> object, however this will not always be so. For example,
 296 if a subroutine has been removed from its Document, to be moved to another
 297 Document.
 298
 299 Returns the top-most PDOM object, which may be the same Element, if it is
 300 not within any parent PDOM object.
 301
 302 =cut
 303
 304 sub top {
 305         my $cursor = shift;
 306         while ( my $parent = $_PARENT{refaddr $cursor} ) {
 307                 $cursor = $parent;
 308         }
 309         $cursor;
 310 }
 311
 312 =pod
 313
 314 For an Element that is contained within a L<PPI::Document> object,
 315 the C<document> method will return the top-level Document for the Element.
 316
 317 Returns the L<PPI::Document> for this Element, or false if the Element is not
 318 contained within a Document.
 319
 320 =cut
 321
 322 sub document {
 323         my $top = shift->top;
 324         _INSTANCE($top, 'PPI::Document') and $top;
 325 }
 326
 327 =pod
 328
 329 =head2 next_sibling
 330
 331 All L<PPI::Node> objects (specifically, our parent Node) contain a number of
 332 C<PPI::Element> objects. The C<next_sibling> method returns the C<PPI::Element>
 333 immediately after the current one, or false if there is no next sibling.
 334
 335 =cut
 336
 337 sub next_sibling {
 338         my $self     = shift;
 339         my $parent   = $_PARENT{refaddr $self} or return '';
 340         my $key      = refaddr $self;
 341         my $elements = $parent->{children};
 342         my $position = List::MoreUtils::firstidx {
 343                 refaddr $_ == $key
 344                 } @$elements;
 345         $elements->[$position + 1] || '';
 346 }
 347
 348 =pod
 349
 350 =head2 snext_sibling
 351
 352 As per the other 's' methods, the C<snext_sibling> method returns the next
 353 B<significant> sibling of the C<PPI::Element> object.
 354
 355 Returns a C<PPI::Element> object, or false if there is no 'next' significant
 356 sibling.
 357
 358 =cut
 359
 360 sub snext_sibling {
 361         my $self     = shift;
 362         my $parent   = $_PARENT{refaddr $self} or return '';
 363         my $key      = refaddr $self;
 364         my $elements = $parent->{children};
 365         my $position = List::MoreUtils::firstidx {
 366                 refaddr $_ == $key
 367                 } @$elements;
 368         while ( defined(my $it = $elements->[++$position]) ) {
 369                 return $it if $it->significant;
 370         }
 371         '';
 372 }
 373
 374 =pod
 375
 376 =head2 previous_sibling
 377
 378 All L<PPI::Node> objects (specifically, our parent Node) contain a number of
 379 C<PPI::Element> objects. The C<previous_sibling> method returns the Element
 380 immediately before the current one, or false if there is no 'previous'
 381 C<PPI::Element> object.
 382
 383 =cut
 384
 385 sub previous_sibling {
 386         my $self     = shift;
 387         my $parent   = $_PARENT{refaddr $self} or return '';
 388         my $key      = refaddr $self;
 389         my $elements = $parent->{children};
 390         my $position = List::MoreUtils::firstidx {
 391                 refaddr $_ == $key
 392                 } @$elements;
 393         $position and $elements->[$position - 1] or '';
 394 }
 395
 396 =pod
 397
 398 =head2 sprevious_sibling
 399
 400 As per the other 's' methods, the C<sprevious_sibling> method returns
 401 the previous B<significant> sibling of the C<PPI::Element> object.
 402
 403 Returns a C<PPI::Element> object, or false if there is no 'previous' significant
 404 sibling.
 405
 406 =cut
 407
 408 sub sprevious_sibling {
 409         my $self     = shift;
 410         my $parent   = $_PARENT{refaddr $self} or return '';
 411         my $key      = refaddr $self;
 412         my $elements = $parent->{children};
 413         my $position = List::MoreUtils::firstidx {
 414                 refaddr $_ == $key
 415                 } @$elements;
 416         while ( $position-- and defined(my $it = $elements->[$position]) ) {
 417                 return $it if $it->significant;
 418         }
 419         '';
 420 }
 421
 422 =pod
 423
 424 =head2 first_token
 425
 426 As a support method for higher-order algorithms that deal specifically with
 427 tokens and actual Perl content, the C<first_token> method finds the first
 428 PPI::Token object within or equal to this one.
 429
 430 That is, if called on a L<PPI::Node> subclass, it will descend until it
 431 finds a L<PPI::Token>. If called on a L<PPI::Token> object, it will return
 432 the same object.
 433
 434 Returns a L<PPI::Token> object, or dies on error (which should be extremely
 435 rare and only occur if an illegal empty L<PPI::Statement> exists below the
 436 current Element somewhere.
 437
 438 =cut
 439
 440 sub first_token {
 441         my $cursor = shift;
 442         while ( $cursor->isa('PPI::Node') ) {
 443                 $cursor = $cursor->first_element
 444                 or die "Found empty PPI::Node while getting first token";
 445         }
 446         $cursor;
 447 }
 448
 449
 450 =pod
 451
 452 =head2 last_token
 453
 454 As a support method for higher-order algorithms that deal specifically with
 455 tokens and actual Perl content, the C<last_token> method finds the last
 456 PPI::Token object within or equal to this one.
 457
 458 That is, if called on a L<PPI::Node> subclass, it will descend until it
 459 finds a L<PPI::Token>. If called on a L<PPI::Token> object, it will return
 460 the itself.
 461
 462 Returns a L<PPI::Token> object, or dies on error (which should be extremely
 463 rare and only occur if an illegal empty L<PPI::Statement> exists below the
 464 current Element somewhere.
 465
 466 =cut
 467
 468 sub last_token {
 469         my $cursor = shift;
 470         while ( $cursor->isa('PPI::Node') ) {
 471                 $cursor = $cursor->last_element
 472                 or die "Found empty PPI::Node while getting first token";
 473         }
 474         $cursor;
 475 }
 476
 477 =pod
 478
 479 =head2 next_token
 480
 481 As a support method for higher-order algorithms that deal specifically with
 482 tokens and actual Perl content, the C<next_token> method finds the
 483 L<PPI::Token> object that is immediately after the current Element, even if
 484 it is not within the same parent L<PPI::Node> as the one for which the
 485 method is being called.
 486
 487 Note that this is B<not> defined as a L<PPI::Token>-specific method,
 488 because it can be useful to find the next token that is after, say, a
 489 L<PPI::Statement>, although obviously it would be useless to want the
 490 next token after a L<PPI::Document>.
 491
 492 Returns a L<PPI::Token> object, or false if there are no more tokens after
 493 the Element.
 494
 495 =cut
 496
 497 sub next_token {
 498         my $cursor = shift;
 499
 500         # Find the next element, going upwards as needed
 501         while ( 1 ) {
 502                 my $element = $cursor->next_sibling;
 503                 if ( $element ) {
 504                         return $element if $element->isa('PPI::Token');
 505                         return $element->first_token;
 506                 }
 507                 $cursor = $cursor->parent or return '';
 508                 if ( $cursor->isa('PPI::Structure') and $cursor->finish ) {
 509                         return $cursor->finish;
 510                 }
 511         }
 512 }
 513
 514 =pod
 515
 516 =head2 previous_token
 517
 518 As a support method for higher-order algorithms that deal specifically with
 519 tokens and actual Perl content, the C<previous_token> method finds the
 520 L<PPI::Token> object that is immediately before the current Element, even
 521 if it is not within the same parent L<PPI::Node> as this one.
 522
 523 Note that this is not defined as a L<PPI::Token>-only method, because it can
 524 be useful to find the token is before, say, a L<PPI::Statement>, although
 525 obviously it would be useless to want the next token before a
 526 L<PPI::Document>.
 527
 528 Returns a L<PPI::Token> object, or false if there are no more tokens before
 529 the C<Element>.
 530
 531 =cut
 532
 533 sub previous_token {
 534         my $cursor = shift;
 535
 536         # Find the previous element, going upwards as needed
 537         while ( 1 ) {
 538                 my $element = $cursor->previous_sibling;
 539                 if ( $element ) {
 540                         return $element if $element->isa('PPI::Token');
 541                         return $element->last_token;
 542                 }
 543                 $cursor = $cursor->parent or return '';
 544                 if ( $cursor->isa('PPI::Structure') and $cursor->start ) {
 545                         return $cursor->start;
 546                 }
 547         }
 548 }
 549
 550
 551
 552
 553
 554 #####################################################################
 555 # Manipulation
 556
 557 =pod
 558
 559 =head2 clone
 560
 561 As per the L<Clone> module, the C<clone> method makes a perfect copy of
 562 an Element object. In the generic case, the implementation is done using
 563 the L<Clone> module's mechanism itself. In higher-order cases, such as for
 564 Nodes, there is more work involved to keep the parent-child links intact.
 565
 566 =cut
 567
 568 sub clone {
 569         Clone::clone(shift);
 570 }
 571
 572 =pod
 573
 574 =head2 insert_before @Elements
 575
 576 The C<insert_before> method allows you to insert lexical perl content, in
 577 the form of C<PPI::Element> objects, before the calling C<Element>. You
 578 need to be very careful when modifying perl code, as it's easy to break
 579 things.
 580
 581 In its initial incarnation, this method allows you to insert a single
 582 Element, and will perform some basic checking to prevent you inserting
 583 something that would be structurally wrong (in PDOM terms).
 584
 585 In future, this method may be enhanced to allow the insertion of multiple
 586 Elements, inline-parsed code strings or L<PPI::Document::Fragment> objects.
 587
 588 Returns true if the Element was inserted, false if it can not be inserted,
 589 or C<undef> if you do not provide a L<PPI::Element> object as a parameter.
 590
 591 =begin testing __insert_before 6
 592
 593 my $Document = PPI::Document->new( \"print 'Hello World';" );
 594 isa_ok( $Document, 'PPI::Document' );
 595 my $semi = $Document->find_first('Token::Structure');
 596 isa_ok( $semi, 'PPI::Token::Structure' );
 597 is( $semi->content, ';', 'Got expected token' );
 598 my $foo = PPI::Token::Word->new('foo');
 599 isa_ok( $foo, 'PPI::Token::Word' );
 600 is( $foo->content, 'foo', 'Created Word token' );
 601 $semi->__insert_before( $foo );
 602 is( $Document->serialize, "print 'Hello World'foo;",
 603         '__insert_before actually inserts' );
 604
 605 =end testing
 606
 607 =begin testing insert_before after __insert_before 6
 608
 609 my $Document = PPI::Document->new( \"print 'Hello World';" );
 610 isa_ok( $Document, 'PPI::Document' );
 611 my $semi = $Document->find_first('Token::Structure');
 612 isa_ok( $semi, 'PPI::Token::Structure' );
 613 is( $semi->content, ';', 'Got expected token' );
 614 my $foo = PPI::Token::Word->new('foo');
 615 isa_ok( $foo, 'PPI::Token::Word' );
 616 is( $foo->content, 'foo', 'Created Word token' );
 617 $semi->insert_before( $foo );
 618 is( $Document->serialize, "print 'Hello World'foo;",
 619         'insert_before actually inserts' );
 620
 621 =end testing
 622
 623 =cut
 624
 625 sub __insert_before {
 626         my $self = shift;
 627         $self->parent->__insert_before_child( $self, @_ );
 628 }
 629
 630 =pod
 631
 632 =head2 insert_after @Elements
 633
 634 The C<insert_after> method allows you to insert lexical perl content, in
 635 the form of C<PPI::Element> objects, after the calling C<Element>. You need
 636 to be very careful when modifying perl code, as it's easy to break things.
 637
 638 In its initial incarnation, this method allows you to insert a single
 639 Element, and will perform some basic checking to prevent you inserting
 640 something that would be structurally wrong (in PDOM terms).
 641
 642 In future, this method may be enhanced to allow the insertion of multiple
 643 Elements, inline-parsed code strings or L<PPI::Document::Fragment> objects.
 644
 645 Returns true if the Element was inserted, false if it can not be inserted,
 646 or C<undef> if you do not provide a L<PPI::Element> object as a parameter.
 647
 648 =begin testing __insert_after 6
 649
 650 my $Document = PPI::Document->new( \"print 'Hello World';" );
 651 isa_ok( $Document, 'PPI::Document' );
 652 my $string = $Document->find_first('Token::Quote');
 653 isa_ok( $string, 'PPI::Token::Quote' );
 654 is( $string->content, "'Hello World'", 'Got expected token' );
 655 my $foo = PPI::Token::Word->new('foo');
 656 isa_ok( $foo, 'PPI::Token::Word' );
 657 is( $foo->content, 'foo', 'Created Word token' );
 658 $string->__insert_after( $foo );
 659 is( $Document->serialize, "print 'Hello World'foo;",
 660         '__insert_after actually inserts' );
 661
 662 =end testing
 663
 664 =begin testing insert_after after __insert_after 6
 665
 666 my $Document = PPI::Document->new( \"print 'Hello World';" );
 667 isa_ok( $Document, 'PPI::Document' );
 668 my $string = $Document->find_first('Token::Quote');
 669 isa_ok( $string, 'PPI::Token::Quote' );
 670 is( $string->content, "'Hello World'", 'Got expected token' );
 671 my $foo = PPI::Token::Word->new('foo');
 672 isa_ok( $foo, 'PPI::Token::Word' );
 673 is( $foo->content, 'foo', 'Created Word token' );
 674 $string->insert_after( $foo );
 675 is( $Document->serialize, "print 'Hello World'foo;",
 676         'insert_after actually inserts' );
 677
 678 =end testing
 679
 680 =cut
 681
 682 sub __insert_after {
 683         my $self = shift;
 684         $self->parent->__insert_after_child( $self, @_ );
 685 }
 686
 687 =pod
 688
 689 =head2 remove
 690
 691 For a given C<PPI::Element>, the C<remove> method will remove it from its
 692 parent B<intact>, along with all of its children.
 693
 694 Returns the C<Element> itself as a convenience, or C<undef> if an error
 695 occurs while trying to remove the C<Element>.
 696
 697 =cut
 698
 699 sub remove {
 700         my $self   = shift;
 701         my $parent = $self->parent or return $self;
 702         $parent->remove_child( $self );
 703 }
 704
 705 =pod
 706
 707 =head2 delete
 708
 709 For a given C<PPI::Element>, the C<remove> method will remove it from its
 710 parent, immediately deleting the C<Element> and all of its children (if it
 711 has any).
 712
 713 Returns true if the C<Element> was successfully deleted, or C<undef> if
 714 an error occurs while trying to remove the C<Element>.
 715
 716 =cut
 717
 718 sub delete {
 719         $_[0]->remove or return undef;
 720         $_[0]->DESTROY;
 721         1;
 722 }
 723
 724 =pod
 725
 726 =head2 replace $Element
 727
 728 Although some higher level class support more exotic forms of replace,
 729 at the basic level the C<replace> method takes a single C<Element> as
 730 an argument and replaces the current C<Element> with it.
 731
 732 To prevent accidental damage to code, in this initial implementation the
 733 replacement element B<must> be of the same class (or a subclass) as the
 734 one being replaced.
 735
 736 =cut
 737
 738 sub replace {
 739         my $self    = ref $_[0] ? shift : return undef;
 740         my $Element = _INSTANCE(shift, ref $self) or return undef;
 741         die "The ->replace method has not yet been implemented";
 742 }
 743
 744 =pod
 745
 746 =head2 location
 747
 748 If the Element exists within a L<PPI::Document> that has
 749 indexed the Element locations using C<PPI::Document::index_locations>, the
 750 C<location> method will return the location of the first character of the
 751 Element within the Document.
 752
 753 Returns the location as a reference to a five-element array in the form C<[
 754 $line, $rowchar, $col, $logical_line, $logical_file_name ]>. The values are in
 755 a human format, with the first character of the file located at C<[ 1, 1, 1, ?,
 756 'something' ]>.
 757
 758 The second and third numbers are similar, except that the second is the
 759 literal horizontal character, and the third is the visual column, taking
 760 into account tabbing (see L<PPI::Document/"tab_width [ $width ]">).
 761
 762 The fourth number is the line number, taking into account any C<#line>
 763 directives.  The fifth element is the name of the file that the element was
 764 found in, if available, taking into account any C<#line> directives.
 765
 766 Returns C<undef> on error, or if the L<PPI::Document> object has not been
 767 indexed.
 768
 769 =cut
 770
 771 sub location {
 772         my $self = shift;
 773
 774         $self->_ensure_location_present or return undef;
 775
 776         # Return a copy, not the original
 777         return [ @{$self->{_location}} ];
 778 }
 779
 780 =pod
 781
 782 =head2 line_number
 783
 784 If the Element exists within a L<PPI::Document> that has indexed the Element
 785 locations using C<PPI::Document::index_locations>, the C<line_number> method
 786 will return the line number of the first character of the Element within the
 787 Document.
 788
 789 Returns C<undef> on error, or if the L<PPI::Document> object has not been
 790 indexed.
 791
 792 =begin testing line_number 3
 793
 794 my $document = PPI::Document->new(\<<'END_PERL');
 795
 796
 797    foo
 798 END_PERL
 799
 800 isa_ok( $document, 'PPI::Document' );
 801 my $words = $document->find('PPI::Token::Word');
 802 is( scalar @{$words}, 1, 'Found expected word token.' );
 803 is( $words->[0]->line_number, 3, 'Got correct line number.' );
 804
 805 =end testing
 806
 807 =cut
 808
 809 sub line_number {
 810         my $self = shift;
 811
 812         my $location = $self->location() or return undef;
 813         return $location->[0];
 814 }
 815
 816 =pod
 817
 818 =head2 column_number
 819
 820 If the Element exists within a L<PPI::Document> that has indexed the Element
 821 locations using C<PPI::Document::index_locations>, the C<column_number> method
 822 will return the column number of the first character of the Element within the
 823 Document.
 824
 825 Returns C<undef> on error, or if the L<PPI::Document> object has not been
 826 indexed.
 827
 828 =begin testing column_number 3
 829
 830 my $document = PPI::Document->new(\<<'END_PERL');
 831
 832
 833    foo
 834 END_PERL
 835
 836 isa_ok( $document, 'PPI::Document' );
 837 my $words = $document->find('PPI::Token::Word');
 838 is( scalar @{$words}, 1, 'Found expected word token.' );
 839 is( $words->[0]->column_number, 4, 'Got correct column number.' );
 840
 841 =end testing
 842
 843 =cut
 844
 845 sub column_number {
 846         my $self = shift;
 847
 848         my $location = $self->location() or return undef;
 849         return $location->[1];
 850 }
 851
 852 =pod
 853
 854 =head2 visual_column_number
 855
 856 If the Element exists within a L<PPI::Document> that has indexed the Element
 857 locations using C<PPI::Document::index_locations>, the C<visual_column_number>
 858 method will return the visual column number of the first character of the
 859 Element within the Document, according to the value of
 860 L<PPI::Document/"tab_width [ $width ]">.
 861
 862 Returns C<undef> on error, or if the L<PPI::Document> object has not been
 863 indexed.
 864
 865 =begin testing visual_column_number 3
 866
 867 my $document = PPI::Document->new(\<<"END_PERL");
 868
 869
 870 \t foo
 871 END_PERL
 872
 873 isa_ok( $document, 'PPI::Document' );
 874 my $tab_width = 5;
 875 $document->tab_width($tab_width);  # don't use a "usual" value.
 876 my $words = $document->find('PPI::Token::Word');
 877 is( scalar @{$words}, 1, 'Found expected word token.' );
 878 is(
 879         $words->[0]->visual_column_number,
 880         $tab_width + 2,
 881         'Got correct visual column number.',
 882 );
 883
 884 =end testing
 885
 886 =cut
 887
 888 sub visual_column_number {
 889         my $self = shift;
 890
 891         my $location = $self->location() or return undef;
 892         return $location->[2];
 893 }
 894
 895 =pod
 896
 897 =head2 logical_line_number
 898
 899 If the Element exists within a L<PPI::Document> that has indexed the Element
 900 locations using C<PPI::Document::index_locations>, the C<logical_line_number>
 901 method will return the line number of the first character of the Element within
 902 the Document, taking into account any C<#line> directives.
 903
 904 Returns C<undef> on error, or if the L<PPI::Document> object has not been
 905 indexed.
 906
 907 =begin testing logical_line_number 3
 908
 909 # Double quoted so that we don't really have a "#line" at the beginning and
 910 # errors in this file itself aren't affected by this.
 911 my $document = PPI::Document->new(\<<"END_PERL");
 912
 913
 914 \#line 1 test-file
 915    foo
 916 END_PERL
 917
 918 isa_ok( $document, 'PPI::Document' );
 919 my $words = $document->find('PPI::Token::Word');
 920 is( scalar @{$words}, 1, 'Found expected word token.' );
 921 is( $words->[0]->logical_line_number, 1, 'Got correct logical line number.' );
 922
 923 =end testing
 924
 925 =cut
 926
 927 sub logical_line_number {
 928         my $self = shift;
 929
 930         return $self->location()->[3];
 931 }
 932
 933 =pod
 934
 935 =head2 logical_filename
 936
 937 If the Element exists within a L<PPI::Document> that has indexed the Element
 938 locations using C<PPI::Document::index_locations>, the C<logical_filename>
 939 method will return the logical file name containing the first character of the
 940 Element within the Document, taking into account any C<#line> directives.
 941
 942 Returns C<undef> on error, or if the L<PPI::Document> object has not been
 943 indexed.
 944
 945 =begin testing logical_filename 3
 946
 947 # Double quoted so that we don't really have a "#line" at the beginning and
 948 # errors in this file itself aren't affected by this.
 949 my $document = PPI::Document->new(\<<"END_PERL");
 950
 951
 952 \#line 1 test-file
 953    foo
 954 END_PERL
 955
 956 isa_ok( $document, 'PPI::Document' );
 957 my $words = $document->find('PPI::Token::Word');
 958 is( scalar @{$words}, 1, 'Found expected word token.' );
 959 is(
 960         $words->[0]->logical_filename,
 961         'test-file',
 962         'Got correct logical line number.',
 963 );
 964
 965 =end testing
 966
 967 =cut
 968
 969 sub logical_filename {
 970         my $self = shift;
 971
 972         my $location = $self->location() or return undef;
 973         return $location->[4];
 974 }
 975
 976 sub _ensure_location_present {
 977         my $self = shift;
 978
 979         unless ( exists $self->{_location} ) {
 980                 # Are we inside a normal document?
 981                 my $Document = $self->document or return undef;
 982                 if ( $Document->isa('PPI::Document::Fragment') ) {
 983                         # Because they can't be serialized, document fragments
 984                         # do not support the concept of location.
 985                         return undef;
 986                 }
 987
 988                 # Generate the locations. If they need one location, then
 989                 # the chances are they'll want more, and it's better that
 990                 # everything is already pre-generated.
 991                 $Document->index_locations or return undef;
 992                 unless ( exists $self->{_location} ) {
 993                         # erm... something went very wrong here
 994                         return undef;
 995                 }
 996         }
 997
 998         return 1;
 999 }
1000
1001 # Although flush_locations is only publically a Document-level method,
1002 # we are able to implement it at an Element level, allowing us to
1003 # selectively flush only the part of the document that occurs after the
1004 # element for which the flush is called.
1005 sub _flush_locations {
1006         my $self  = shift;
1007         unless ( $self == $self->top ) {
1008                 return $self->top->_flush_locations( $self );
1009         }
1010
1011         # Get the full list of all Tokens
1012         my @Tokens = $self->tokens;
1013
1014         # Optionally allow starting from an arbitrary element (or rather,
1015         # the first Token equal-to-or-within an arbitrary element)
1016         if ( _INSTANCE($_[0], 'PPI::Element') ) {
1017                 my $start = shift->first_token;
1018                 while ( my $Token = shift @Tokens ) {
1019                         return 1 unless $Token->{_location};
1020                         next unless refaddr($Token) == refaddr($start);
1021
1022                         # Found the start. Flush it's location
1023                         delete $$Token->{_location};
1024                         last;
1025                 }
1026         }
1027
1028         # Iterate over any remaining Tokens and flush their location
1029         foreach my $Token ( @Tokens ) {
1030                 delete $Token->{_location};
1031         }
1032
1033         1;
1034 }
1035
1036
1037
1038
1039
1040 #####################################################################
1041 # XML Compatibility Methods
1042
1043 sub _xml_name {
1044         my $class = ref $_[0] || $_[0];
1045         my $name  = lc join( '_', split /::/, $class );
1046         substr($name, 4);
1047 }
1048
1049 sub _xml_attr {
1050         return {};
1051 }
1052
1053 sub _xml_content {
1054         defined $_[0]->{content} ? $_[0]->{content} : '';
1055 }
1056
1057
1058
1059
1060
1061 #####################################################################
1062 # Internals
1063
1064 # Set the error string
1065 sub _error {
1066         $errstr = $_[1];
1067         undef;
1068 }
1069
1070 # Clear the error string
1071 sub _clear {
1072         $errstr = '';
1073         $_[0];
1074 }
1075
1076 # Being DESTROYed in this manner, rather than by an explicit
1077 # ->delete means our reference count has probably fallen to zero.
1078 # Therefore we don't need to remove ourselves from our parent,
1079 # just the index ( just in case ).
1080 ### XS -> PPI/XS.xs:_PPI_Element__DESTROY 0.900+
1081 sub DESTROY { delete $_PARENT{refaddr $_[0]} }
1082
1083 # Operator overloads
1084 sub __equals  { ref $_[1] and refaddr($_[0]) == refaddr($_[1]) }
1085 sub __nequals { !__equals(@_) }
1086 sub __eq {
1087         my $self  = _INSTANCE($_[0], 'PPI::Element') ? $_[0]->content : $_[0];
1088         my $other = _INSTANCE($_[1], 'PPI::Element') ? $_[1]->content : $_[1];
1089         $self eq $other;
1090 }
1091 sub __ne { !__eq(@_) }
1092
1093 1;
1094
1095 =pod
1096
1097 =head1 TO DO
1098
1099 It would be nice if C<location> could be used in an ad-hoc manner. That is,
1100 if called on an Element within a Document that has not been indexed, it will
1101 do a one-off calculation to find the location. It might be very painful if
1102 someone started using it a lot, without remembering to index the document,
1103 but it would be handy for things that are only likely to use it once, such
1104 as error handlers.
1105
1106 =head1 SUPPORT
1107
1108 See the L<support section|PPI/SUPPORT> in the main module.
1109
1110 =head1 AUTHOR
1111
1112 Adam Kennedy E<lt>adamk@cpan.orgE<gt>
1113
1114 =head1 COPYRIGHT
1115
1116 Copyright 2001 - 2009 Adam Kennedy.
1117
1118 This program is free software; you can redistribute
1119 it and/or modify it under the same terms as Perl itself.
1120
1121 The full text of the license can be found in the
1122 LICENSE file included with this module.
1123
1124 =cut