local-lib5/lib/perl5/PPI/Token/_QuoteEngine/Full.pm

   1 package PPI::Token::_QuoteEngine::Full;
   2
   3 # Full quote engine
   4
   5 use strict;
   6 use Clone                    ();
   7 use Carp                     ();
   8 use PPI::Token::_QuoteEngine ();
   9
  10 use vars qw{$VERSION @ISA %quotes %sections};
  11 BEGIN {
  12         $VERSION = '1.206';
  13         @ISA     = 'PPI::Token::_QuoteEngine';
  14
  15         # Prototypes for the different braced sections
  16         %sections = (
  17                 '(' => { type => '()', _close => ')' },
  18                 '<' => { type => '<>', _close => '>' },
  19                 '[' => { type => '[]', _close => ']' },
  20                 '{' => { type => '{}', _close => '}' },
  21         );
  22
  23         # For each quote type, the extra fields that should be set.
  24         # This should give us faster initialization.
  25         %quotes = (
  26                 'q'   => { operator => 'q',   braced => undef, separator => undef, _sections => 1 },
  27                 'qq'  => { operator => 'qq',  braced => undef, separator => undef, _sections => 1 },
  28                 'qx'  => { operator => 'qx',  braced => undef, separator => undef, _sections => 1 },
  29                 'qw'  => { operator => 'qw',  braced => undef, separator => undef, _sections => 1 },
  30                 'qr'  => { operator => 'qr',  braced => undef, separator => undef, _sections => 1, modifiers => 1 },
  31                 'm'   => { operator => 'm',   braced => undef, separator => undef, _sections => 1, modifiers => 1 },
  32                 's'   => { operator => 's',   braced => undef, separator => undef, _sections => 2, modifiers => 1 },
  33                 'tr'  => { operator => 'tr',  braced => undef, separator => undef, _sections => 2, modifiers => 1 },
  34
  35                 # Y is the little used varient of tr
  36                 'y'   => { operator => 'y',   braced => undef, separator => undef, _sections => 2, modifiers => 1 },
  37
  38                 '/'   => { operator => undef, braced => 0,     separator => '/',   _sections => 1, modifiers => 1 },
  39
  40                 # Angle brackets quotes mean "readline(*FILEHANDLE)"
  41                 '<'   => { operator => undef, braced => 1,     separator => undef, _sections => 1, },
  42
  43                 # The final ( and kind of depreciated ) "first match only" one is not
  44                 # used yet, since I'm not sure on the context differences between
  45                 # this and the trinary operator, but its here for completeness.
  46                 '?'   => { operator => undef, braced => 0,     separator => '?',   _sections => 1, modifiers => 1 },
  47         );
  48 }
  49
  50 =pod
  51
  52 =begin testing new 70
  53
  54 # Verify that Token::Quote, Token::QuoteLike and Token::Regexp
  55 # do not have ->new functions
  56 my $RE_SYMBOL  = qr/\A(?!\d)\w+\z/;
  57 foreach my $name ( qw{Token::Quote Token::QuoteLike Token::Regexp} ) {
  58         no strict 'refs';
  59         my @functions = sort
  60                 grep { defined &{"${name}::$_"} }
  61                 grep { /$RE_SYMBOL/o }
  62                 keys %{"PPI::${name}::"};
  63         is( scalar(grep { $_ eq 'new' } @functions), 0,
  64                 "$name does not have a new function" );
  65 }
  66
  67 # This primarily to ensure that qw() with non-balanced types
  68 # are treated the same as those with balanced types.
  69 SCOPE: {
  70         my @seps   = ( undef, undef, '/', '#', ','  );
  71         my @types  = ( '()', '<>', '//', '##', ',,' );
  72         my @braced = ( qw{ 1 1 0 0 0 } );
  73         my $i      = 0;
  74         for my $q ('qw()', 'qw<>', 'qw//', 'qw##', 'qw,,') {
  75                 my $d = PPI::Document->new(\$q);
  76                 my $o = $d->{children}->[0]->{children}->[0];
  77                 my $s = $o->{sections}->[0];
  78                 is( $o->{operator},  'qw',      "$q correct operator"  );
  79                 is( $o->{_sections}, 1,         "$q correct _sections" );
  80                 is( $o->{braced}, $braced[$i],  "$q correct braced"    );
  81                 is( $o->{separator}, $seps[$i], "$q correct seperator" );
  82                 is( $o->{content},   $q,        "$q correct content"   );
  83                 is( $s->{position},  3,         "$q correct position"  );
  84                 is( $s->{type}, $types[$i],     "$q correct type"      );
  85                 is( $s->{size},      0,         "$q correct size"      );
  86                 $i++;
  87         }
  88 }
  89
  90 SCOPE: {
  91         my @stuff  = ( qw-( ) < > / / -, '#', '#', ',',',' );
  92         my @seps   = ( undef, undef, '/', '#', ','  );
  93         my @types  = ( '()', '<>', '//', '##', ',,' );
  94         my @braced = ( qw{ 1 1 0 0 0 } );
  95         my @secs   = ( qw{ 1 1 0 0 0 } );
  96         my $i      = 0;
  97         while ( @stuff ) {
  98                 my $opener = shift @stuff;
  99                 my $closer = shift @stuff;
 100                 my $d = PPI::Document->new(\"qw$opener");
 101                 my $o = $d->{children}->[0]->{children}->[0];
 102                 my $s = $o->{sections}->[0];
 103                 is( $o->{operator},  'qw',        "qw$opener correct operator"  );
 104                 is( $o->{_sections}, $secs[$i],   "qw$opener correct _sections" );
 105                 is( $o->{braced}, $braced[$i],    "qw$opener correct braced"    );
 106                 is( $o->{separator}, $seps[$i],   "qw$opener correct seperator" );
 107                 is( $o->{content},   "qw$opener", "qw$opener correct content"   );
 108                 if ( $secs[$i] ) {
 109                         is( $s->{type}, "$opener$closer", "qw$opener correct type"      );
 110                 }
 111                 $i++;
 112         }
 113 }
 114
 115 =end testing
 116
 117 =cut
 118
 119 sub new {
 120         my $class = shift;
 121         my $init  = defined $_[0]
 122                 ? shift
 123                 : Carp::croak("::Full->new called without init string");
 124
 125         # Create the token
 126         ### This manual SUPER'ing ONLY works because none of
 127         ### Token::Quote, Token::QuoteLike and Token::Regexp
 128         ### implement a new function of their own.
 129         my $self = PPI::Token::new( $class, $init ) or return undef;
 130
 131         # Do we have a prototype for the intializer? If so, add the extra fields
 132         my $options = $quotes{$init} or return $self->_error(
 133                 "Unknown quote type '$init'"
 134         );
 135         foreach ( keys %$options ) {
 136                 $self->{$_} = $options->{$_};
 137         }
 138
 139         # Set up the modifiers hash if needed
 140         $self->{modifiers} = {} if $self->{modifiers};
 141
 142         # Handle the special < base
 143         if ( $init eq '<' ) {
 144                 $self->{sections}->[0] = Clone::clone( $sections{'<'} );
 145         }
 146
 147         $self;
 148 }
 149
 150 sub _fill {
 151         my $class = shift;
 152         my $t     = shift;
 153         my $self  = $t->{token}
 154                 or Carp::croak("::Full->_fill called without current token");
 155
 156         # Load in the operator stuff if needed
 157         if ( $self->{operator} ) {
 158                 # In an operator based quote-like, handle the gap between the
 159                 # operator and the opening separator.
 160                 if ( substr( $t->{line}, $t->{line_cursor}, 1 ) =~ /\s/ ) {
 161                         # Go past the gap
 162                         my $gap = $self->_scan_quote_like_operator_gap( $t );
 163                         return undef unless defined $gap;
 164                         if ( ref $gap ) {
 165                                 # End of file
 166                                 $self->{content} .= $$gap;
 167                                 return 0;
 168                         }
 169                         $self->{content} .= $gap;
 170                 }
 171
 172                 # The character we are now on is the separator. Capture,
 173                 # and advance into the first section.
 174                 my $sep = substr( $t->{line}, $t->{line_cursor}++, 1 );
 175                 $self->{content} .= $sep;
 176
 177                 # Determine if these are normal or braced type sections
 178                 if ( my $section = $sections{$sep} ) {
 179                         $self->{braced}        = 1;
 180                         $self->{sections}->[0] = Clone::clone($section);
 181                 } else {
 182                         $self->{braced}        = 0;
 183                         $self->{separator}     = $sep;
 184                 }
 185         }
 186
 187         # Parse different based on whether we are normal or braced
 188         my $rv = $self->{braced}
 189                 ? $self->_fill_braced($t)
 190                 : $self->_fill_normal($t);
 191         return $rv if !$rv;
 192
 193         # Return now unless it has modifiers ( i.e. s/foo//eieio )
 194         return 1 unless $self->{modifiers};
 195
 196         # Check for modifiers
 197         my $char;
 198         my $len = 0;
 199         while ( ($char = substr( $t->{line}, $t->{line_cursor} + 1, 1 )) =~ /[^\W\d_]/ ) {
 200                 $len++;
 201                 $self->{content} .= $char;
 202                 $self->{modifiers}->{lc $char} = 1;
 203                 $t->{line_cursor}++;
 204         }
 205 }
 206
 207 # Handle the content parsing path for normally seperated
 208 sub _fill_normal {
 209         my $self = shift;
 210         my $t    = shift;
 211
 212         # Get the content up to the next separator
 213         my $string = $self->_scan_for_unescaped_character( $t, $self->{separator} );
 214         return undef unless defined $string;
 215         if ( ref $string ) {
 216                 # End of file
 217                 $self->{content} .= $$string;
 218                 if ( length($$string) > 1 )  {
 219                         # Complete the properties for the first section
 220                         my $str = $$string;
 221                         chop $str;
 222                         $self->{sections}->[0] = {
 223                                 position => length($self->{content}),
 224                                 size     => length($string),
 225                                 type     => "$self->separator$self->separator",
 226                         };
 227                 } else {
 228                         # No sections at all
 229                         $self->{_sections} = 0;
 230                 }
 231                 return 0;
 232         }
 233
 234         # Complete the properties of the first section
 235         $self->{sections}->[0] = {
 236                 position => length $self->{content},
 237                 size     => length($string) - 1,
 238                 type     => "$self->{separator}$self->{separator}"
 239         };
 240         $self->{content} .= $string;
 241
 242         # We are done if there is only one section
 243         return 1 if $self->{_sections} == 1;
 244
 245         # There are two sections.
 246
 247         # Advance into the next section
 248         $t->{line_cursor}++;
 249
 250         # Get the content up to the end separator
 251         $string = $self->_scan_for_unescaped_character( $t, $self->{separator} );
 252         return undef unless defined $string;
 253         if ( ref $string ) {
 254                 # End of file
 255                 $self->{content} .= $$string;
 256                 return 0;
 257         }
 258
 259         # Complete the properties of the second section
 260         $self->{sections}->[1] = {
 261                 position => length($self->{content}),
 262                 size     => length($string) - 1
 263         };
 264         $self->{content} .= $string;
 265
 266         1;
 267 }
 268
 269 # Handle content parsing for matching crace seperated
 270 sub _fill_braced {
 271         my $self = shift;
 272         my $t    = shift;
 273
 274         # Get the content up to the close character
 275         my $section   = $self->{sections}->[0];
 276         my $brace_str = $self->_scan_for_brace_character( $t, $section->{_close} );
 277         return undef unless defined $brace_str;
 278         if ( ref $brace_str ) {
 279                 # End of file
 280                 $self->{content} .= $$brace_str;
 281                 return 0;
 282         }
 283
 284         # Complete the properties of the first section
 285         $section->{position} = length $self->{content};
 286         $section->{size}     = length($brace_str) - 1;
 287         $self->{content} .= $brace_str;
 288         delete $section->{_close};
 289
 290         # We are done if there is only one section
 291         return 1 if $self->{_sections} == 1;
 292
 293         # There are two sections.
 294
 295         # Is there a gap between the sections.
 296         my $char = substr( $t->{line}, ++$t->{line_cursor}, 1 );
 297         if ( $char =~ /\s/ ) {
 298                 # Go past the gap
 299                 my $gap_str = $self->_scan_quote_like_operator_gap( $t );
 300                 return undef unless defined $gap_str;
 301                 if ( ref $gap_str ) {
 302                         # End of file
 303                         $self->{content} .= $$gap_str;
 304                         return 0;
 305                 }
 306                 $self->{content} .= $gap_str;
 307                 $char = substr( $t->{line}, $t->{line_cursor}, 1 );
 308         }
 309
 310         $section = $sections{$char};
 311         unless ( $section ) {
 312                 # Error, it has to be a brace of some sort.
 313                 # Although this will result in a REALLY illegal regexp,
 314                 # we allow it anyway.
 315
 316                 # Create a null second section
 317                 $self->{sections}->[1] = {
 318                         position => length($self->{content}),
 319                         size     => 0,
 320                         type     => '',
 321                 };
 322
 323                 # Attach an error to the token and move on
 324                 $self->{_error} = "No second section of regexp, or does not start with a balanced character";
 325
 326                 # Roll back the cursor one char and return signalling end of regexp
 327                 $t->{line_cursor}--;
 328                 return 0;
 329         }
 330
 331         # Initialize the second section
 332         $self->{content} .= $char;
 333         $section = $self->{sections}->[1] = { %$section };
 334
 335         # Advance into the second region
 336         $t->{line_cursor}++;
 337         $section->{position} = length($self->{content});
 338         $section->{size}     = 0;
 339
 340         # Get the content up to the close character
 341         $brace_str = $self->_scan_for_brace_character( $t, $section->{_close} );
 342         return undef unless defined $brace_str;
 343         if ( ref $brace_str ) {
 344                 # End of file
 345                 $self->{content} .= $$brace_str;
 346                 $section->{size} = length($$brace_str);
 347                 delete $section->{_close};
 348                 return 0;
 349         } else {
 350                 # Complete the properties for the second section
 351                 $self->{content} .= $brace_str;
 352                 $section->{size} = length($brace_str) - 1;
 353                 delete $section->{_close};
 354         }
 355
 356         1;
 357 }
 358
 359
 360
 361
 362
 363 #####################################################################
 364 # Additional methods to find out about the quote
 365
 366 # In a scalar context, get the number of sections
 367 # In an array context, get the section information
 368 sub _sections { wantarray ? @{$_[0]->{sections}} : scalar @{$_[0]->{sections}} }
 369
 370 1;
 371
 372 =pod
 373
 374 =head1 SUPPORT
 375
 376 See the L<support section|PPI/SUPPORT> in the main module.
 377
 378 =head1 AUTHOR
 379
 380 Adam Kennedy E<lt>adamk@cpan.orgE<gt>
 381
 382 =head1 COPYRIGHT
 383
 384 Copyright 2001 - 2009 Adam Kennedy.
 385
 386 This program is free software; you can redistribute
 387 it and/or modify it under the same terms as Perl itself.
 388
 389 The full text of the license can be found in the
 390 LICENSE file included with this module.
 391
 392 =cut