File Coverage

blib/lib/PPIx/QuoteLike.pm

Criterion	Covered	Total	%
statement	390	429	90.9
branch	152	222	68.4
condition	43	67	64.1
subroutine	63	68	92.6
pod	24	24	100.0
total	672	810	82.9

package PPIx::QuoteLike;

use 5.006;

use strict;
use warnings;

use Carp;
use Encode ();
use List::Util ();
use PPIx::QuoteLike::Constant qw{
    ARRAY_REF
    LOCATION_LINE
    LOCATION_CHARACTER
    LOCATION_COLUMN
    LOCATION_LOGICAL_LINE
    LOCATION_LOGICAL_FILE
    MINIMUM_PERL
    VARIABLE_RE
    @CARP_NOT
};
use PPIx::QuoteLike::Token::Control;
use PPIx::QuoteLike::Token::Delimiter;
use PPIx::QuoteLike::Token::Interpolation;
use PPIx::QuoteLike::Token::String;
use PPIx::QuoteLike::Token::Structure;
use PPIx::QuoteLike::Token::Unknown;
use PPIx::QuoteLike::Token::Whitespace;
use PPIx::QuoteLike::Utils qw{
    column_number
    line_number
    logical_filename
    logical_line_number
    statement
    visual_column_number
    __instance
    __match_enclosed
    __matching_delimiter
};
use Scalar::Util ();

our $VERSION = '0.023';

use constant CLASS_CONTROL       => 'PPIx::QuoteLike::Token::Control';
use constant CLASS_DELIMITER     => 'PPIx::QuoteLike::Token::Delimiter';
use constant CLASS_INTERPOLATION => 'PPIx::QuoteLike::Token::Interpolation';
use constant CLASS_STRING        => 'PPIx::QuoteLike::Token::String';
use constant CLASS_STRUCTURE     => 'PPIx::QuoteLike::Token::Structure';
use constant CLASS_UNKNOWN       => 'PPIx::QuoteLike::Token::Unknown';
use constant CLASS_WHITESPACE    => 'PPIx::QuoteLike::Token::Whitespace';

use constant CODE_REF	=> ref sub {};

use constant ILLEGAL_FIRST	=>
    'Tokenizer found illegal first characters';
use constant MISMATCHED_DELIM	=>
    'Tokenizer found mismatched delimiters';
use constant NO_INDENTATION	=>
    'No indentation string found';

{
    my $match_sq = __match_enclosed( qw< ' > );
    my $match_dq = __match_enclosed( qw< " > );
    my $match_bt = __match_enclosed( qw< ` > );

    sub new {	## no critic (RequireArgUnpacking)
	my ( $class, $source, %arg ) = @_;

	my @children;

	if ( $arg{location} ) {
	    ARRAY_REF eq ref $arg{location}
		or croak q;
	    foreach my $inx ( 0 .. 3 ) {
		$arg{location}[$inx] =~ m/ [^0-9] /smx
		    and croak "Argument 'location' element $inx must be an unsigned integer";
	    }
	}

	if ( ! defined $arg{index_locations} ) {
	    $arg{index_locations} = !! $arg{location} ||
		__instance( $source, 'PPI::Element' );
	}

	my $self = {
	    index_locations	=> $arg{index_locations},
	    children	=> \@children,
	    encoding	=> $arg{encoding},
	    failures	=> 0,
	    location	=> $arg{location},
	    source	=> $source,
	};

	bless $self, ref $class || $class;

	defined( my $string = $self->_stringify_source( $source ) )
	    or return;

	my ( $type, $gap, $gap2, $content, $end_delim, $indented, $start_delim );

	$arg{trace}
	    and warn "Initial match of $string\n";

	# q<>, qq<>, qx<>
	if ( $string =~ m/ \A \s* ( q [qx]? ) ( \s* ) ( . ) /smxgc ) {
	    ( $type, $gap, $start_delim ) = ( $1, $2, $3 );
	    not $gap
		and $start_delim =~ m< \A \w \z >smx
		and return $self->_link_elems( $self->_make_token(
		    CLASS_UNKNOWN, $string, error => ILLEGAL_FIRST ) );
	    $arg{trace}
		and warn "Initial match '$type$start_delim'\n";
	    $self->{interpolates} = 'qq' eq $type ||
		'qx' eq $type && q<'> ne $start_delim;
	    $content = substr $string, ( pos $string || 0 );
	    $end_delim = __matching_delimiter( $start_delim );
	    if ( $end_delim eq substr $content, -1 ) {
		chop $content;
	    } else {
		$end_delim = '';
	    }

	# here doc
	# Note that the regexp used here is slightly wrong in that white
	# space between the '<<' and the termination string is not
	# allowed if the termination string is not quoted in some way.
	} elsif ( $string =~ m/ \A \s* ( << ) ( \s* ) ( ~? ) ( \s* )
	    ( [\\]? \w+ | $match_sq | $match_dq | $match_bt ) \n /smxgc ) {
	    ( $type, $gap, $indented, $gap2, $start_delim ) = (
		$1, $2, $3, $4, $5 );
	    $arg{trace}
		and warn "Initial match '$type$start_delim$gap$indented'\n";
	    $self->{interpolates} = $start_delim !~ m/ \A [\\'] /smx;
	    $content = substr $string, ( pos $string || 0 );
	    $end_delim = _unquote( $start_delim );
	    # NOTE that the indentation is specifically space or tab
	    # only.
	    if ( $content =~ s/ ^ ( [ \t]* ) \Q$end_delim\E \n? \z //smx ) {
		# NOTE PPI::Token::HereDoc does not preserve the
		# indentation of an indented here document, so the
		# indentation will appear to be '' if we came from PPI.
		if ( $indented ) {
		    # Version per perldelta.pod for that release.
		    $self->{perl_version_introduced} = '5.025007';
		    $self->{indentation} = "$1";
		    $self->{_indentation_re} = qr/
			^ \Q$self->{indentation}\E /smx;
		}
	    } else {
		$end_delim = '';
	    }
	    $self->{start} = [
		$self->_make_token( CLASS_DELIMITER, $start_delim ),
		$self->_make_token( CLASS_WHITESPACE, "\n" ),
	    ];

	    # Don't instantiate yet -- we'll do them at the end.
	    $self->{finish} = [
		[ CLASS_DELIMITER, $end_delim ],
		[ CLASS_WHITESPACE, "\n" ],
	    ];

	# ``, '', "", <>
	} elsif ( $string =~ m/ \A \s* ( [`'"<] ) /smxgc ) {
	    ( $type, $gap, $start_delim ) = ( '', '', $1 );
	    $arg{trace}
		and warn "Initial match '$type$start_delim'\n";
	    $self->{interpolates} = q<'> ne $start_delim;
	    $content = substr $string, ( pos $string || 0 );
	    $end_delim = __matching_delimiter( $start_delim );
	    if ( $end_delim eq substr $content, -1 ) {
		chop $content;
	    } else {
		$end_delim = '';
	    }

	# Something we do not recognize
	} else {
	    $arg{trace}
		and warn "No initial match\n";
	    return $self->_link_elems( $self->_make_token(
		    CLASS_UNKNOWN, $string, error => ILLEGAL_FIRST ) );
	}

	$self->{interpolates} = $self->{interpolates} ? 1 : 0;

	defined or $_ = '' for $indented, $gap2;
	$self->{type} = [
	    $self->_make_token( CLASS_STRUCTURE, $type ),
	    length $gap ?
		$self->_make_token( CLASS_WHITESPACE, $gap ) :
		(),
	    length $indented ?
	        $self->_make_token( CLASS_STRUCTURE, $indented ) :
		(),
	    length $gap2 ?
		$self->_make_token( CLASS_WHITESPACE, $gap2 ) :
		(),
	];
	$self->{start} ||= [
	    $self->_make_token( CLASS_DELIMITER, $start_delim ),
	];

	$arg{trace}
	    and warn "Without delimiters: '$content'\n";

	# We accumulate data and manufacure tokens at the end to reduce
	# the overhead involved in merging strings.
	if ( $self->{interpolates} ) {
	    push @children, [ '' => '' ];	# Prime the pump
	    while ( 1 ) {

		if ( $content =~ m/ \G ( \\ [ULulQEF] ) /smxgc ) {
		    push @children, [ CLASS_CONTROL, "$1" ];
		} elsif (
		    $content =~ m/ \G ( \\ N [{] ( [^}]+ ) [}] ) /smxgc
		) {
		    # Handle \N{...} separately because it can not
		    # contain an interpolation even inside of an
		    # otherwise-interpolating string. That is to say,
		    # "\N{$foo}" is simply invalid, and does not even
		    # try to interpolate $foo.  {
		    # TODO use $re = __match_enclosed( '{' ); # }
		    my ( $seq, $name ) = ( $1, $2 );
		    # TODO The Regexp is certainly too permissive. For
		    # the moment all I am doing is disallowing
		    # interpolation.
		    push @children, $name =~ m/ [\$\@] /smx ?
			[ CLASS_UNKNOWN, $seq,
			    error => "Unknown charname '$name'" ] :
			[ CLASS_STRING, $seq ];
		# NOTE in the following that I do not read perldata as
		# saying there can be space between the sigil and the
		# variable name, but Perl itself seems to accept it as
		# of 5.30.1.
		} elsif ( $content =~ m/ \G ( [\$\@] \#? \$* ) /smxgc ) {
		    push @children, $self->_interpolation( "$1", $content );
		} elsif ( $content =~ m/ \G ( \\ . | [^\\\$\@]+ ) /smxgc ) {
		    push @children, $self->_remove_here_doc_indentation(
			"$1",
			sibling	=> \@children,
		    );
		} else {
		    last;
		}
	    }

	    @children = _merge_strings( @children );
	    shift @children;	# remove the priming

	    # Make the tokens, at long last.
	    foreach ( @children ) {
		$_ = $self->_make_token( @{ $_ } );
	    }

	} else {

	    length $content
		and push @children, map { $self->_make_token( @{ $_ } ) }
		    _merge_strings(
			$self->_remove_here_doc_indentation( $content )
			);

	}

	# Add the indentation before the end marker, if needed
	$self->{indentation}
	    and push @children, $self->_make_token(
	    CLASS_WHITESPACE, $self->{indentation} );

	if ( $self->{finish} ) {
	    # If we already have something here it is data, not objects.
	    foreach ( @{ $self->{finish} } ) {
		$_ = $self->_make_token( @{ $_ } );
	    }
	} else {
	    $self->{finish} = [
		$self->_make_token( CLASS_DELIMITER, $end_delim ),
	    ];
	}

	ref $_[1]
	    and pos( $_[1] ) = pos $string;

	return $self->_link_elems();
    }
}

sub child {
    my ( $self, $number ) = @_;
    return $self->{children}[$number];
}

sub children {
    my ( $self ) = @_;
    return @{ $self->{children} };
}

sub content {
    my ( $self ) = @_;
    return join '', map { $_->content() } grep { $_ } $self->elements();
}

sub delimiters {
    my ( $self ) = @_;
    return join '', grep { defined }
	map { $self->_get_value_scalar( $_ ) }
	qw{ start finish };
}

#	$self->_deprecation_notice( $type, $name );
#
#	This method centralizes deprecation. Type is 'attribute' or
#	'method'. Deprecation is driven of the %deprecate hash. Values
#	are:
#	    false - no warning
#	    1 - warn on first use
#	    2 - warn on each use
#	    3 - die on each use.
#
#	$self->_deprecation_in_progress( $type, $name )
#
#	This method returns true if the deprecation is in progress. In
#	fact it returns the deprecation level.

=begin comment

# Abandoned in place, against future need.

{

    my %deprecate = (
	attribute => {
	    postderef	=> 3,
	},
    );

    sub _deprecation_notice {
	my ( undef, $type, $name, $repl ) = @_;		# Invocant unused
	$deprecate{$type} or return;
	$deprecate{$type}{$name} or return;
	my $msg = sprintf 'The %s %s is %s', $name, $type,
	    $deprecate{$type}{$name} > 2 ? 'removed' : 'deprecated';
	defined $repl
	    and $msg .= "; use $repl instead";
	$deprecate{$type}{$name} >= 3
	    and croak $msg;
	warnings::enabled( 'deprecated' )
	    and carp $msg;
	$deprecate{$type}{$name} == 1
	    and $deprecate{$type}{$name} = 0;
	return;
    }

}

=end comment

=cut

sub _get_value_scalar {
    my ( $self, $method ) = @_;
    defined( my $val = $self->$method() )
	or return;
    return ref $val ? $val->content() : $val;
}

sub elements {
    my ( $self ) = @_;
    return @{ $self->{elements} ||= [
	map { $self->$_() } qw{ type start children finish }
    ] };
}

sub encoding {
    my ( $self ) = @_;
    return $self->{encoding};
}

sub failures {
    my ( $self ) = @_;
    return $self->{failures};
}

sub find {
    my ( $self, $target ) = @_;

    my $check = CODE_REF eq ref $target ? $target :
    ref $target ? croak 'find() target may not be ' . ref $target :
    sub { $_[0]->isa( $target ) };
    my @found;
    foreach my $elem ( $self, $self->elements() ) {
	$check->( $elem )
	    and push @found, $elem;
    }

    @found
	or return 0;

    return \@found;
}

sub finish {
    my ( $self, $inx ) = @_;
    $self->{finish}
	or return;
    wantarray
	and return @{ $self->{finish} };
    return $self->{finish}[ $inx || 0 ];
}

sub handles {
    my ( $self, $string ) = @_;
    return $self->_stringify_source( $string, test => 1 );
}

sub indentation {
    my ( $self ) = @_;
    return $self->{indentation};
}

sub interpolates {
    my ( $self ) = @_;
    return $self->{interpolates};
}

sub location {
    my ( $self ) = @_;
    return $self->type()->location();
}

sub _make_token {
    my ( $self, $class, $content, %arg ) = @_;
    my $token = $class->__new( content => $content, %arg );
    CLASS_UNKNOWN eq $class
	and $self->{failures}++;
    $self->{index_locations}
	and $self->_update_location( $token );
    return $token;
}

sub _update_location {
    my ( $self, $token ) = @_;
    $token->{location}	# Idempotent
	and return;
    my $loc = $self->{_location} ||= do {
	my %loc = (
	    line_content	=> '',
	    location		=> $self->{location},
	);
	if ( __instance( $self->{source}, 'PPI::Element' ) ) {
	    $loc{location} ||= $self->{source}->location();
	    if ( my $doc = $self->{source}->document() ) {
		$loc{tab_width} = $doc->tab_width();
	    }
	}
	$loc{tab_width} ||= 1;
	\%loc;
    };
    $loc->{location}
	or return;
    $token->{location} = [ @{ $loc->{location} } ];

    if ( defined( my $content = $token->content() ) ) {

	my $lines;
	pos( $content ) = 0;
	$lines++ while $content =~ m/ \n /smxgc;
	if ( pos $content ) {
	    $loc->{location}[LOCATION_LINE] += $lines;
	    $loc->{location}[LOCATION_LOGICAL_LINE] += $lines;
	    $loc->{location}[LOCATION_CHARACTER] =
		$loc->{location}[LOCATION_COLUMN] = 1;
	}

	if ( my $chars = length( $content ) - pos( $content ) ) {
	    $loc->{location}[LOCATION_CHARACTER] += $chars;
	    if ( $loc->{tab_width} > 1 && $content =~ m/ \t /smx ) {
		my $pos = $loc->{location}[LOCATION_COLUMN];
		my $tab_width = $loc->{tab_width};
		# Stolen shamelessly from PPI::Document::_visual_length
		my ( $vis_inc );
		foreach my $part ( split /(\t)/, $content ) {
		    if ($part eq "\t") {
			$vis_inc = $tab_width - ($pos-1) % $tab_width;
		    } else {
			$vis_inc = length $part;
		    }
		    $pos    += $vis_inc;
		}
		$loc->{location}[LOCATION_COLUMN] = $pos;
	    } else {
		$loc->{location}[LOCATION_COLUMN] += $chars;
	    }
	}

    }

    return;
}

sub parent {
    return;
}

sub perl_version_introduced {
    my ( $self ) = @_;
    return List::Util::max( grep { defined $_ } MINIMUM_PERL,
	$self->{perl_version_introduced},
	map { $_->perl_version_introduced() } $self->elements() );
}

sub perl_version_removed {
    my ( $self ) = @_;
    my $max;
    foreach my $elem ( $self->elements() ) {
	if ( defined ( my $ver = $elem->perl_version_removed() ) ) {
	    if ( defined $max ) {
		$ver < $max and $max = $ver;
	    } else {
		$max = $ver;
	    }
	}
    }
    return $max;
}

sub schild {
    my ( $self, $inx ) = @_;
    $inx ||= 0;
    my @kids = $self->schildren();
    return $kids[$inx];
}

sub schildren {
    my ( $self ) = @_;
    return (
	grep { $_->significant() } $self->children()
    );
}

sub source {
    my ( $self ) = @_;
    return $self->{source};
}

sub start {
    my ( $self, $inx ) = @_;
    $self->{start}
	or return;
    wantarray
	and return @{ $self->{start} };
    return $self->{start}[ $inx || 0 ];
}

sub top {
    my ( $self ) = @_;
    return $self;
}

sub type {
    my ( $self, $inx ) = @_;
    $self->{type}
	or return;
    wantarray
	and return @{ $self->{type} };
    return $self->{type}[ $inx || 0 ];
}

sub variables {
    my ( $self ) = @_;

    $self->interpolates()
	or return;

    my %var;
    foreach my $kid ( $self->children() ) {
	foreach my $sym ( $kid->variables() ) {
	    $var{$sym} = 1;
	}
    }
    return ( keys %var );
}

sub _chop {
    my ( $middle ) = @_;
    my $left = substr $middle, 0, 1, '';
    my $right = substr $middle, -1, 1, '';
    return ( $left, $middle, $right );
}

# decode data using the object's {encoding}
# It is anticipated that if I make PPIx::Regexp depend on this package,
# that this will be called there.

sub __decode {
    my ( $self, $data, $encoding ) = @_;
    $encoding ||= $self->{encoding};
    defined $encoding
	and _encode_available()
	or return $data;
    return Encode::decode( $encoding, $data );
}

{

    my $encode_available;

    sub _encode_available {
	defined $encode_available and return $encode_available;
	return ( $encode_available = eval {
		require Encode;
		1;
	    } ? 1 : 0
	);
    }

}

{
    my ( $cached_doc, $cached_encoding );

    # These are the byte order marks documented as being recognized by
    # PPI. Only utf-8 is documented as supported.
    my %known_bom = (
	'EFBBBF'	=> 'utf-8',
	'0000FEFF'	=> 'utf-32be',
	'FFFE0000'	=> 'utf-32le',
	'FEFF'		=> 'utf-16be',
	'FFFE'		=> 'utf-16le',
    );

    sub _get_ppi_encoding {
	my ( $elem ) = @_;

	my $doc = $elem->top()
	    or return;

	$cached_doc
	    and $doc == $cached_doc
	    and return $cached_encoding;

	my $bom = $doc->first_element()
	    or return;

	Scalar::Util::weaken( $cached_doc = $doc );

	if ( $bom->isa( 'PPI::Token::BOM' ) ) {
	    return ( $cached_encoding = $known_bom{
		uc unpack 'H*', $bom->content() } );
	}

	$cached_encoding = undef;

	foreach my $use (
	    @{ $doc->find( 'PPI::Statement::Include' ) || [] }
	) {
	    'use' eq $use->type()
		or next;
	    defined( my $module = $use->module() )
		or next;
	    'utf8' eq $module
		or next;
	    $cached_encoding = 'utf-8';
	    last;
	}

	return $cached_encoding;

    }

}

# This subroutine was created in an attempt to simplify control flow.
# Argument 2 (from 0) is not unpacked because the caller needs to see
# the side effects of matches made on it.

{

    my %special = (
	'$$'	=> sub {	# Process ID.
	    my ( undef, $sigil ) = @_;
	    return [ CLASS_INTERPOLATION, $sigil ];
	},
	'$'	=> sub {	# Called if we find (e.g.) '$@'
	    my ( undef, $sigil ) = @_;
	    $_[2] =~ m/ \G ( [\@] ) /smxgc
		or return;
	    return [ CLASS_INTERPOLATION, "$sigil$1" ];
	},
	'@'	=> sub {	# Called if we find '@@'.
	    my ( undef, $sigil ) = @_;
	    return [ CLASS_STRING, $sigil ];
	},
    );

    sub _interpolation {	## no critic (RequireArgUnpacking)
	my ( $self, $sigil ) = @_;
	# Argument $_[2] is $content, but we can't unpack it because we
	# need the caller to see any changes to pos().

	if ( $_[2] =~ m/ \G (?= \{ ) /smxgc ) {
	    # variable name enclosed in {}
	    my $delim_re = __match_enclosed( qw< { > );
	    if ( $_[2] =~ m/ \G $delim_re /smxgc ) {
		my $rest = $1;
		$rest =~ m/ \A \{ \s* \[ ( .* ) \] \s* \} \z /smx
		    or return [ CLASS_INTERPOLATION, "$sigil$rest" ];
		# At this point we have @{[ ... ]}.
		my @arg;
		_has_postderef( "$1" )
		    and push @arg, postderef => 1;
		return [ CLASS_INTERPOLATION, "$sigil$rest", @arg ];
	    }
	    $_[2] =~ m/ \G ( .* ) /smxgc
		and return [ CLASS_UNKNOWN, "$sigil$1",
		    error => MISMATCHED_DELIM ];
	    confess 'Failed to match /./';
	}

	if ( $_[2] =~ m< \G ( @{[ VARIABLE_RE ]} ) >smxgco
	) {
	    # variable name not enclosed in {}
	    my $interp = "$sigil$1";
	    while ( $_[2] =~ m/ \G  ( (?: -> )? ) (?= ( [[{] ) ) /smxgc ) { # }]
		my $lead_in = $1;
		my $delim_re = __match_enclosed( $2 );
		if ( $_[2] =~ m/ \G ( $delim_re ) /smxgc ) {
		    $interp .= "$lead_in$1";
		} else {
		    $_[2] =~ m/ ( .* ) /smxgc;
		    return (
			[ CLASS_INTERPOLATION, $interp ],
			[ CLASS_UNKNOWN, "$1", error => MISMATCHED_DELIM ],
		    );
		}
	    }

	    my @arg;

	    if ( defined( my $deref = _match_postderef( $_[2] ) ) ) {
		$interp .= $deref;
		push @arg, postderef => 1;
	    }

	    return [ CLASS_INTERPOLATION, $interp, @arg ];
	}

	my $code;
	$code = $special{$sigil}
	    and my $elem = $code->( $self, $sigil, $_[2] )
	    or return [ CLASS_UNKNOWN, $sigil,
		error => 'Sigil without interpolation' ];

	return $elem;
    }

}

sub _link_elems {
    my ( $self, @arg ) = @_;

    push @{ $self->{children} }, @arg;

    foreach my $key ( qw{ type start children finish } ) {
	my $prev;
	foreach my $elem ( @{ $self->{$key} } ) {
	    Scalar::Util::weaken( $elem->{parent} = $self );
	    if ( $prev ) {
		Scalar::Util::weaken( $elem->{previous_sibling} = $prev );
		Scalar::Util::weaken( $prev->{next_sibling} = $elem );
	    }
	    $prev = $elem;
	}
    }

    return $self;
}

{
    my %allow_subscr	= map { $_ => 1 } qw{ % @ };

    # Match a postfix deref at the current position in the argument. If
    # a match occurs it is returned, and the current position is
    # updated. If not, nothing is returned, and the current position in
    # the argument remains unchanged.
    # This would all be much easier if I could count on Perl 5.10
    sub _match_postderef {	## no critic (RequireArgUnpacking)
	my $pos = pos $_[0];
	# Only scalars and arrays interpolate
	$_[0] =~ m/ \G ( -> ) ( \$ \# | [\$\@] ) /smxgc
	    or return;
	my $match = "$1$2";
	my $sigil = $2;
	$_[0] =~ m/ \G ( [*] ) /smxgc
	    and return "$match$1";

	if (
	    $allow_subscr{$sigil} &&
	    $_[0] =~ m/ \G (?= ( [[{] ) ) /smxgc	# }]
	) {
	    my $re = __match_enclosed( "$1" );
	    $_[0] =~ m/ \G $re /smxgc
		and return "$match$1";
	}

	pos $_[0] = $pos;
	return;
    }
}

{
    no warnings qw{ qw };	## no critic (ProhibitNoWarnings)
    my %is_postderef = map { $_ => 1 } qw{ $ $# @ % & * $* $#* @* %* &* ** };
    sub _has_postderef {
	my ( $string ) = @_;
	my $doc = PPI::Document->new( \$string );
	foreach my $elem ( @{ $doc->find( 'PPI::Token::Symbol' ) || [] } ) {
	    my $next = $elem->snext_sibling()
		or next;
	    $next->isa( 'PPI::Token::Operator' )
		or next;
	    $next->content() eq '->'
		or next;
	    $next = $next->snext_sibling()
		or next;
	    $next->isa( 'PPI::Token::Cast' )
		or next;
	    my $content = $next->content();
	    $is_postderef{$content}
		or next;
	    $content =~ m/ \* \z /smx
		and return 1;
	    $next = $next->snext_sibling()
		or next;
	    $next->isa( 'PPI::Structure::Subscript' )
		and return 1;
	}
	return 0;
    }
}

# For various reasons we may get consecutive literals -- typically
# strings. We want to merge these. The arguments are array refs, with
# the class name of the token in [0] and the content in [1]. I know of
# no way we can generate consecutive white space tokens, but if I did I
# would want them merged.
#
# NOTE that merger loses all attributes of the second token, so we MUST
# NOT merge CLASS_UNKNOWN tokens, or any class that might have
# attributes other than content.
{
    my %can_merge = map { $_ => 1 } CLASS_STRING, CLASS_WHITESPACE;

    sub _merge_strings {
	my @arg = @_;
	my @rslt;
	foreach my $elem ( @arg ) {
	    if ( @rslt && $can_merge{$elem->[0]}
		&& $elem->[0] eq $rslt[-1][0]
	    ) {
		$rslt[-1][1] .= $elem->[1];
	    } else {
		push @rslt, $elem;
	    }
	}
	return @rslt;
    }
}

# If we're processing an indented here document, strings must be split
# on new lines and un-indented. We return array refs rather than
# objects because we may be called before we're ready to build the
# objects.
sub _remove_here_doc_indentation {
    my ( $self, $string, %arg ) = @_;

    # NOTE that we rely on the fact that both undef (not indented) and
    # '' (indented by zero characters) evaluate false.
    $self->{indentation}
	or return [ CLASS_STRING, $string ];

    my $ignore_first;
    if ( $arg{sibling} ) {
	# Because the calling code primes the pump, @sibling will never
	# be empty, even when processing the first token. So:
	# * The pump-priming specifies class '', so if that is what we
	#   see we must process the first line; otherwise
	# * If the previous token is a string ending in "\n", we must
	#   process the first line.
	$ignore_first = '' ne $arg{sibling}[-1][0] && (
	    CLASS_STRING ne $arg{sibling}[-1][0] ||
	    $arg{sibling}[-1][1] !~ m/ \n \z /smx );
    } else {
	# Without @sibling, we unconditionally process the first line.
	$ignore_first = 0;
    }

    my @rslt;

    foreach ( split qr/ (?<= \n ) /smx, $string ) {
	if ( $ignore_first ) {
	    push @rslt, [ CLASS_STRING, "$_" ];
	    $ignore_first = 0;
	} else {
	    if ( "\n" eq $_ ) {
		push @rslt,
		    [ CLASS_STRING, "$_" ],
		    ;
	    } elsif ( s/ ( $self->{_indentation_re} ) //smx ) {
		push @rslt,
		    [ CLASS_WHITESPACE, "$1" ],
		    [ CLASS_STRING, "$_" ],
		    ;
	    } else {
		push @rslt,
		    [ CLASS_UNKNOWN, "$_", error => NO_INDENTATION ],
		    ;
	    }
	}
    }

    return @rslt;
}

sub _stringify_source {
    my ( $self, $string, %opt ) = @_;

    if ( Scalar::Util::blessed( $string ) ) {

	$string->isa( 'PPI::Element' )
	    or return;

	foreach my $class ( qw{
	    PPI::Token::Quote
	    PPI::Token::QuoteLike::Backtick
	    PPI::Token::QuoteLike::Command
	    PPI::Token::QuoteLike::Readline
	} ) {
	    $string->isa( $class )
		or next;
	    $opt{test}
		and return 1;

	    my $encoding = _get_ppi_encoding( $string );
	    return $self->__decode( $string->content(), $encoding );
	}

	if ( $string->isa( 'PPI::Token::HereDoc' ) ) {
	    $opt{test}
		and return 1;

	    my $encoding = _get_ppi_encoding( $string );
	    my $heredoc = join '',
		map { $self->__decode( $_, $encoding) }
		$string->heredoc();
	    my $terminator = $self->__decode( $string->terminator(),
		$encoding );
	    $terminator =~ s/ (?<= \n ) \z /\n/smx;
	    return $self->__decode( $string->content(), $encoding ) .
		"\n" . $heredoc . $terminator;
	}

	return;

    }

    ref $string
	and return;

    $string =~ m/ \A \s* (?: q [qx]? | << | [`'"<] ) /smx
	and return $opt{test} ? 1 : $string;

    return;
}

sub _unquote {
    my ( $string ) = @_;
    $string =~ s/ \A ['"] //smx
	and chop $string;
    $string =~ s/ \\ (?= . ) //smxg;
    return $string;
}

1;

__END__