File Coverage

blib/lib/PPIx/Regexp/Tokenizer.pm

Criterion	Covered	Total	%
statement	494	522	94.6
branch	177	238	74.3
condition	44	64	68.7
subroutine	85	89	95.5
pod	29	29	100.0
total	829	942	88.0

package PPIx::Regexp::Tokenizer;

use strict;
use warnings;

use base qw{ PPIx::Regexp::Support };

use Carp qw{ carp croak confess };
use PPIx::Regexp::Constant qw{
    ARRAY_REF
    CODE_REF
    HASH_REF
    LOCATION_LINE
    LOCATION_CHARACTER
    LOCATION_COLUMN
    LOCATION_LOGICAL_LINE
    MINIMUM_PERL
    REGEXP_REF
    TOKEN_LITERAL
    TOKEN_UNKNOWN
    @CARP_NOT
};
use PPIx::Regexp::Token::Assertion		();
use PPIx::Regexp::Token::Backreference		();
use PPIx::Regexp::Token::Backtrack		();
use PPIx::Regexp::Token::CharClass::POSIX	();
use PPIx::Regexp::Token::CharClass::POSIX::Unknown	();
use PPIx::Regexp::Token::CharClass::Simple	();
use PPIx::Regexp::Token::Code			();
use PPIx::Regexp::Token::Comment		();
use PPIx::Regexp::Token::Condition		();
use PPIx::Regexp::Token::Control		();
use PPIx::Regexp::Token::Delimiter		();
use PPIx::Regexp::Token::Greediness		();
use PPIx::Regexp::Token::GroupType::Assertion	();
use PPIx::Regexp::Token::GroupType::Atomic_Script_Run	();
use PPIx::Regexp::Token::GroupType::BranchReset	();
use PPIx::Regexp::Token::GroupType::Code	();
use PPIx::Regexp::Token::GroupType::Modifier	();
use PPIx::Regexp::Token::GroupType::NamedCapture	();
use PPIx::Regexp::Token::GroupType::Script_Run	();
use PPIx::Regexp::Token::GroupType::Subexpression	();
use PPIx::Regexp::Token::GroupType::Switch	();
use PPIx::Regexp::Token::Interpolation		();
use PPIx::Regexp::Token::Literal		();
use PPIx::Regexp::Token::Modifier		();
use PPIx::Regexp::Token::Operator		();
use PPIx::Regexp::Token::Quantifier		();
use PPIx::Regexp::Token::Recursion		();
use PPIx::Regexp::Token::Structure		();
use PPIx::Regexp::Token::Unknown		();
use PPIx::Regexp::Token::Whitespace		();
use PPIx::Regexp::Util qw{
    is_ppi_regexp_element
    __instance
};

use Scalar::Util qw{ looks_like_number };

our $VERSION = '0.087_01';

our $DEFAULT_POSTDEREF;
defined $DEFAULT_POSTDEREF
    or $DEFAULT_POSTDEREF = 1;

{
    # Names of classes containing tokenization machinery. There are few
    # known ordering requirements, since each class recognizes its own,
    # and I have tried to prevent overlap. Absent such constraints, the
    # order is in perceived frequency of acceptance, to keep the search
    # as short as possible. If I were conscientious I would gather
    # statistics on this.
    my @classes = (	# TODO make readonly when acceptable way appears
	'PPIx::Regexp::Token::Literal',
	'PPIx::Regexp::Token::Interpolation',
	'PPIx::Regexp::Token::Control',			# Note 1
	'PPIx::Regexp::Token::CharClass::Simple',	# Note 2
	'PPIx::Regexp::Token::Quantifier',
	'PPIx::Regexp::Token::Greediness',
	'PPIx::Regexp::Token::CharClass::POSIX',	# Note 3
	'PPIx::Regexp::Token::Structure',
	'PPIx::Regexp::Token::Assertion',
	'PPIx::Regexp::Token::Backreference',
	'PPIx::Regexp::Token::Operator',		# Note 4
    );

    # Note 1: If we are in quote mode ( \Q ... \E ), Control makes a
    #		literal out of anything it sees other than \E. So it
    #		needs to come before almost all other tokenizers. Not
    #		Literal, which already makes literals, and not
    #		Interpolation, which is legal in quote mode, but
    #		everything else.

    # Note 2: CharClass::Simple must come after Literal, because it
    #		relies on Literal to recognize a Unicode named character
    #		( \N{something} ), so any \N that comes through to it
    #		must be the \N simple character class (which represents
    #		anything but a newline, and was introduced in Perl
    #		5.11.0.

    # Note 3: CharClass::POSIX has to come before Structure, since both
    #		look for square brackets, and CharClass::POSIX is the
    #		more particular.

    # Note 4: Operator relies on Literal making the characters literal
    #		if they appear in a context where they can not be
    #		operators, and Control making them literals if quoting,
    #		so it must come after both.

    # Return the declared tokenizer classes.
    sub __tokenizer_classes {
	return @classes;
    }

}

{
    my $errstr;

    sub new {
	my ( $class, $re, %args ) = @_;
	ref $class and $class = ref $class;

	$errstr = undef;

	exists $args{default_modifiers}
	    and ARRAY_REF ne ref $args{default_modifiers}
	    and do {
		$errstr = 'default_modifiers must be an array reference';
		return;
	    };

	my $self = {
	    index_locations => $args{index_locations},	# Index locations
	    capture => undef,	# Captures from find_regexp.
	    content => undef,	# The string we are tokenizing.
	    cookie => {},	# Cookies
	    cursor_curr => 0,	# The current position in the string.
	    cursor_limit => undef, # The end of the portion of the
	    			   # string being tokenized.
	    cursor_orig => undef, # Position of cursor when tokenizer
	    			# called. Used by get_token to prevent
				# recursion.
	    cursor_modifiers => undef,	# Position of modifiers.
	    default_modifiers => $args{default_modifiers} || [],
	    delimiter_finish => undef,	# Finishing delimiter of regexp.
	    delimiter_start => undef,	# Starting delimiter of regexp.
	    encoding => $args{encoding}, # Character encoding.
	    expect => undef,	# Extra classes to expect.
	    expect_next => undef, # Extra classes as of next parse cycle
	    failures => 0,	# Number of parse failures.
	    find => undef,	# String for find_regexp
	    known => {},	# Known tokenizers, by mode.
	    location => $args{location},
	    match => undef,	# Match from find_regexp.
	    mode => 'init',	# Initialize
	    modifiers => [{}],	# Modifier hash.
	    pending => [],	# Tokens made but not returned.
	    prior => TOKEN_UNKNOWN,	# Prior significant token.
	    source => $re,	# The object we were initialized with.
	    strict => $args{strict},	# like "use re 'strict';".
	    trace => __PACKAGE__->__defined_or(
		$args{trace}, $ENV{PPIX_REGEXP_TOKENIZER_TRACE}, 0 ),
	};

	if ( __instance( $re, 'PPI::Element' ) ) {
	    is_ppi_regexp_element( $re )
		or return __set_errstr( ref $re, 'not supported by', $class );
	    # TODO conditionalizstion on PPI class does not really
	    # belong here, but at the moment I have no other idea of
	    # where to put it.
	    $self->{content} = $re->isa( 'PPI::Token::HereDoc' ) ?
		join( '', $re->content(), "\n", $re->heredoc(),
		    $re->terminator(), "\n" ) :
		$re->content();
	} elsif ( ref $re ) {
	    return __set_errstr( ref $re, 'not supported' );
	} else {
	    $self->{content} = $re;
	}

	bless $self, $class;

	$self->{content} = $self->decode( $self->{content} );

	$self->{cursor_limit} = length $self->{content};

	$self->{trace}
	    and warn "\ntokenizing '$self->{content}'\n";

	return $self;
    }

    sub __set_errstr {
	$errstr = join ' ', @_;
	return;
    }

    sub errstr {
	return $errstr;
    }

}

sub capture {
    my ( $self ) = @_;
    $self->{capture} or return;
    defined wantarray or return;
    return wantarray ? @{ $self->{capture} } : $self->{capture};
}

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

sub cookie {
    my ( $self, $name, @args ) = @_;
    defined $name
	or confess "Programming error - undefined cookie name";
    if ( $self->{trace} ) {
	local $" = ', ';
	warn "cookie( '$name', @args )\n";
    }
    @args or return $self->{cookie}{$name};
    my $cookie = shift @args;
    if ( CODE_REF eq ref $cookie ) {
	return ( $self->{cookie}{$name} = $cookie );
    } elsif ( defined $cookie ) {
	confess "Programming error - cookie must be CODE ref or undef";
    } else {
	return delete $self->{cookie}{$name};
    }
}

# NOTE: Currently this is called only against
# COOKIE_LOOKAROUND_ASSERTION, once in PPIx::Token::GroupType::Assertion
# to prevent the cookie from being remade if it already exists, and once
# in PPIx::Regexp::Token::Assertion to determine if \K is inside a
# lookaround assertion. If it gets used other places, or if there is
# call for it, I should consider removing the underscores and
# documenting it as public.
sub __cookie_exists {
    my ( $self, $name ) = @_;
    defined $name
	or confess "Programming error - undefined cookie name";
    return $self->{cookie}{$name};
}

sub default_modifiers {
    my ( $self ) = @_;
    return [ @{ $self->{default_modifiers} } ];
}

sub __effective_modifiers {
    my ( $self ) = @_;
    HASH_REF eq ref $self->{effective_modifiers}
	or return {};
    return { %{ $self->{effective_modifiers} } };
}

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

sub expect {
    my ( $self, @args ) = @_;

    @args
	or return;

    $self->{expect_next} = [
	map { m/ \A PPIx::Regexp:: /smx ? $_ : 'PPIx::Regexp::' . $_ }
	@args
    ];
    $self->{expect} = undef;
    return;
}

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

sub find_matching_delimiter {
    my ( $self ) = @_;
    $self->{cursor_curr} ||= 0;
    my $start = substr
	$self->{content},
	$self->{cursor_curr},
	1;

    my $inx = $self->{cursor_curr};
    my $finish = (
	my $bracketed = $self->close_bracket( $start ) ) || $start;

=begin comment

    $self->{trace}
	and warn "Find matching delimiter: Start with '$start' at $self->{cursor_curr}, end with '$finish' at or before $self->{cursor_limit}\n";

=end comment

=cut

    my $nest = 0;

    while ( ++$inx < $self->{cursor_limit} ) {
	my $char = substr $self->{content}, $inx, 1;

=begin comment

	$self->{trace}
	    and warn "    looking at '$char' at $inx, nest level $nest\n";

=end comment

=cut

	if ( $char eq '\\' && $finish ne '\\' ) {
	    ++$inx;
	} elsif ( $bracketed && $char eq $start ) {
	    ++$nest;
	} elsif ( $char eq $finish ) {
	    --$nest < 0
		and return $inx - $self->{cursor_curr};
	}
    }

    return;
}

sub find_regexp {
    my ( $self, $regexp ) = @_;

    REGEXP_REF eq ref $regexp
	or confess
	'Argument is a ', ( ref $regexp || 'scalar' ), ' not a Regexp';

    defined $self->{find} or $self->_remainder();

    $self->{find} =~ $regexp
	or return;

    my @capture;
    foreach my $inx ( 0 .. $#+ ) {
	if ( defined $-[$inx] && defined $+[$inx] ) {
	push @capture, $self->{capture} = substr
		    $self->{find},
		    $-[$inx],
		    $+[$inx] - $-[$inx];
	} else {
	    push @capture, undef;
	}
    }
    $self->{match} = shift @capture;
    $self->{capture} = \@capture;

    # The following circumlocution seems to be needed under Perl 5.13.0
    # for reasons I do not fathom -- at least in the case where
    # wantarray is false. RT 56864 details the symptoms, which I was
    # never able to reproduce outside Perl::Critic. But returning $+[0]
    # directly, the value could transmogrify between here and the
    # calling module.
##  my @data = ( $-[0], $+[0] );
##  return wantarray ? @data : $data[1];
    return wantarray ? ( $-[0] + 0, $+[0] + 0 ) : $+[0] + 0;
}

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

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

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

    caller eq __PACKAGE__ or $self->{cursor_curr} > $self->{cursor_orig}
	or confess 'Programming error - get_token() called without ',
	    'first calling make_token()';

    my $handler = '__PPIX_TOKENIZER__' . $self->{mode};

    my $code = $self->can( $handler )
	or confess 'Programming error - ',
	    "Getting token in mode '$self->{mode}'. ",
	    "cursor_curr = $self->{cursor_curr}; ",
	    "cursor_limit = $self->{cursor_limit}; ",
	    "length( content ) = ", length $self->{content},
	    "; content = '$self->{content}'";

    my $character = substr(
	$self->{content},
	$self->{cursor_curr},
	1
    );

    $self->{trace}
	and warn "get_token() got '$character' from $self->{cursor_curr}\n";

    return ( $code->( $self, $character ) );
}

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

sub make_token {
    my ( $self, $length, $class, $arg ) = @_;
    defined $class or $class = caller;

    if ( $length + $self->{cursor_curr} > $self->{cursor_limit} ) {
	$length = $self->{cursor_limit} - $self->{cursor_curr}
	    or return;
    }

    $class =~ m/ \A PPIx::Regexp:: /smx
	or $class = 'PPIx::Regexp::' . $class;
    my $content = substr
	    $self->{content},
	    $self->{cursor_curr},
	    $length;

    $self->{trace}
	and warn "make_token( $length, '$class' ) => '$content'\n";
    $self->{trace} > 1
	and warn "    make_token: cursor_curr = $self->{cursor_curr}; ",
	    "cursor_limit = $self->{cursor_limit}\n";
    my $token = $class->__new( $content,
	tokenizer	=> $self,
	%{ $arg || {} } )
	or return;

    $self->{index_locations}
	and $self->_update_location( $token );

    $token->significant()
	and $self->{expect} = undef;

    $token->isa( TOKEN_UNKNOWN ) and $self->{failures}++;

    $self->{cursor_curr} += $length;
    $self->{find} = undef;
    $self->{match} = undef;
    $self->{capture} = undef;

    foreach my $name ( keys %{ $self->{cookie} } ) {
	my $cookie = $self->{cookie}{$name};
	$cookie->( $self, $token )
	    or delete $self->{cookie}{$name};
    }

    # Record this token as the prior token if it is significant. We must
    # do this after processing cookies, so that the cookies have access
    # to the old token if they want.
    $token->significant()
	and $self->{prior_significant_token} = $token;

    return $token;
}

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

sub modifier {
    my ( $self, $modifier ) = @_;
    return PPIx::Regexp::Token::Modifier::__asserts(
	$self->{modifiers}[-1], $modifier );
}

sub modifier_duplicate {
    my ( $self ) = @_;
    push @{ $self->{modifiers} },
	{ %{ $self->{modifiers}[-1] } };
    return;
}

sub modifier_modify {
    my ( $self, %args ) = @_;

    # Modifier code is centralized in PPIx::Regexp::Token::Modifier
    $self->{modifiers}[-1] =
	PPIx::Regexp::Token::Modifier::__PPIX_TOKENIZER__modifier_modify(
	$self->{modifiers}[-1], \%args );

    return;

}

sub modifier_pop {
    my ( $self ) = @_;
    @{ $self->{modifiers} } > 1
	and pop @{ $self->{modifiers} };
    return;
}

sub modifier_seen {
    my ( $self, $modifier ) = @_;
    foreach my $mod ( reverse @{ $self->{modifiers} } ) {
	exists $mod->{$modifier}
	    and return 1;
    }
    return;
}

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

    {

	if ( @{ $self->{pending} } ) {
	    return shift @{ $self->{pending} };
	}

	if ( $self->{cursor_curr} >= $self->{cursor_limit} ) {
	    $self->{cursor_limit} >= length $self->{content}
		and return;
	    $self->{mode} eq 'finish' and return;
	    $self->_set_mode( 'finish' );
	    $self->{cursor_limit} += length $self->{delimiter_finish};
	}

	if ( my @tokens = $self->get_token() ) {
	    push @{ $self->{pending} }, @tokens;
	    redo;

	}

    }

    return;

}

sub peek {
    my ( $self, $offset ) = @_;
    defined $offset or $offset = 0;
    $offset < 0 and return;
    $offset += $self->{cursor_curr};
    $offset >= $self->{cursor_limit} and return;
    return substr $self->{content}, $offset, 1;
}

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

    defined $self->{find} or $self->_remainder();

    return PPI::Document->new( \"$self->{find}" );
}

sub prior_significant_token {
    my ( $self, $method, @args ) = @_;
    defined $method or return $self->{prior_significant_token};
    $self->{prior_significant_token}->can( $method )
	or confess 'Programming error - ',
	    ( ref $self->{prior_significant_token} ||
		$self->{prior_significant_token} ),
	    ' does not support method ', $method;
    return $self->{prior_significant_token}->$method( @args );
}

# my $length = $token->__recognize_postderef( $tokenizer, $iterator ).
#
# This method is private to the PPIx-Regexp package, and may be changed
# or retracted without warning. What it does is to recognize postfix
# dereferences. It returns the length in characters of the first postfix
# dereference found, or a false value if none is found.
#
# The optional $iterator argument can be one of the following:
#   - A code reference, which will be called to provide PPI::Element
#     objects to be checked to see if they represent a postfix
#     dereference.
#   - A PPI::Element, which is checked to see if it is a postfix
#     dereference.
#   - Undef, or omitted, in which case ppi() is called on the invocant,
#     and everything that follows the '->' operator is checked to see if
#     it is a postfix dereference.
#   - Anything else results in an exception and stack trace.

{
    sub __recognize_postderef {
	my ( $self, $token, $iterator ) = @_;

	# Note that if ppi() gets called I have to hold a reference to
	# the returned object until I am done with all its children.
	my $ppi;
	if ( ! defined $iterator ) {

	    # This MUST be done before ppi() is called.
	    $self->{index_locations}
		and $self->_update_location( $token );

	    $ppi = $token->ppi();
	    my @ops = grep { '->' eq $_->content() } @{
		$ppi->find( 'PPI::Token::Operator' ) || [] };
	    $iterator = sub {
		my $op = shift @ops
		    or return;
		return $op->snext_sibling();
	    };
	} elsif ( $iterator->isa( 'PPI::Element' ) ) {
	    my @eles = ( $iterator );
	    $iterator = sub {
		return shift @eles;
	    };
	} elsif ( CODE_REF ne ref $iterator ) {
	    confess 'Programming error - Iterator not understood';
	}

	my $accept = $token->__postderef_accept_cast();

	while ( my $elem = $iterator->() ) {

	    my $content = $elem->content();

	    # As of PPI 1.238, all postfix dereferences are parsed as
	    # casts. So if we find a cast of the correct content we have
	    # a postfix deref.
	    $elem->isa( 'PPI::Token::Cast' )
		or next;

	    if ( $content =~ m/ ( .* ) \* \z /smx ) {
		# If we're an acceptable cast ending in a glob, accept
		# it.
		$accept->{$1}
		    and return length $content;
	    } elsif ( $accept->{$content} ) {
		# If we're an acceptable cast followed by a subscript,
		# we're a slice -- accept both cast and subscript.
		my $next = $elem->snext_sibling()
		    or next;
		$next->isa( 'PPI::Structure::Subscript' )
		    or next;
		return length( $content ) + length( $next->content() );
	    }

	    # Otherwise, we're not a postfix dereference; try the next
	    # iteration.
	}

	# No postfix dereference found.
	return;
    }
}

sub significant {
    return 1;
}

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

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

    my $mode = $self->{mode};

    my @expect;
    if ( $self->{expect_next} ) {
	$self->{expect} = $self->{expect_next};
	$self->{expect_next} = undef;
    }
    if ( $self->{expect} ) {
	@expect = $self->_known_tokenizer_check(
	    @{ $self->{expect} } );
    }

    exists $self->{known}{$mode} and return (
	@expect, @{ $self->{known}{$mode} } );

    my @found = $self->_known_tokenizer_check(
	$self->__tokenizer_classes() );

    $self->{known}{$mode} = \@found;
    return (@expect, @found);
}

sub _known_tokenizer_check {
    my ( $self, @args ) = @_;

    my $handler = '__PPIX_TOKENIZER__' . $self->{mode};
    my @found;

    foreach my $class ( @args ) {

	$class->can( $handler ) or next;
	push @found, $class;

    }

    return @found;
}

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

    my @rslt;
    while ( my $token = $self->next_token() ) {
	push @rslt, $token;
    }

    return @rslt;
}

#	$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

{

    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;
    }

    sub _deprecation_in_progress {
	my ( $self, $type, $name ) = @_;
	$deprecate{$type} or return;
	return $deprecate{$type}{$name};
    }

}

=end comment

=cut

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

    $self->{cursor_curr} > $self->{cursor_limit}
	and confess "Programming error - Trying to find past end of string";
    $self->{find} = substr(
	$self->{content},
	$self->{cursor_curr},
	$self->{cursor_limit} - $self->{cursor_curr}
    );

    return;
}

sub _make_final_token {
    my ( $self, $len, $class, $arg ) = @_;
    my $token = $self->make_token( $len, $class, $arg );
    $self->_set_mode( 'kaput' );
    return $token;
}

sub _set_mode {
    my ( $self, $mode ) = @_;
    $self->{trace}
	and warn "Tokenizer going from mode $self->{mode} to $mode\n";
    $self->{mode} = $mode;
    if ( 'kaput' eq $mode ) {
	$self->{cursor_curr} = $self->{cursor_limit} =
	    length $self->{content};
    }
    return;
}

sub __init_error {
    my ( $self , $err ) = @_;
    defined $err
	or $err = 'Tokenizer found illegal first characters';
    return $self->_make_final_token(
	length $self->{content}, TOKEN_UNKNOWN, {
	    error	=> $err,
	},
    );
}

sub _update_location {
    my ( $self, $token ) = @_;
    $token->{location}	# Idempotent
	and return;
    my $loc = $self->{_location} ||= do {
	my %loc = (
	    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 __PPIX_TOKENIZER__init {
    my ( $self ) = @_;

    $self->find_regexp(
	qr{ \A ( \s* ) ( qr | m | s )? ( \s* ) ( . ) }smx )
	or return $self->__init_error();

    my ( $leading_white, $type, $next_white, $delim_start ) = $self->capture();

    defined $type
	or $type = '';

    $type
	or $delim_start =~ m< \A [/?] \z >smx
	or return $self->__init_error();
    $type
	and not $next_white
	and $delim_start =~ m< \A \w \z >smx
	and return $self->__init_error();

    $self->{type} = $type;

    my @tokens;

    '' ne $leading_white
	and push @tokens, $self->make_token( length $leading_white,
	'PPIx::Regexp::Token::Whitespace' );
    push @tokens, $self->make_token( length $type,
	'PPIx::Regexp::Token::Structure' );
    '' ne $next_white
	and push @tokens, $self->make_token( length $next_white,
	'PPIx::Regexp::Token::Whitespace' );

    $self->{delimiter_start} = $delim_start;

    $self->{trace}
	and warn "Tokenizer found regexp start delimiter '$delim_start' at $self->{cursor_curr}\n";

    if ( my $offset = $self->find_matching_delimiter() ) {
	my $cursor_limit = $self->{cursor_curr} + $offset;
	$self->{trace}
	    and warn "Tokenizer found regexp end delimiter at $cursor_limit\n";
	if ( $self->__number_of_extra_parts() ) {
###	    my $found_embedded_comments;
	    if ( $self->close_bracket(
		    $self->{delimiter_start} ) ) {
		pos $self->{content} = $self->{cursor_curr} +
		$offset + 1;
		# If we're bracketed, there may be Perl comments between
		# the regex and the replacement. PPI gets the parse
		# wrong as of 1.220, but if we get the handling of the
		# underlying string right, we will Just Work when PPI
		# gets it right.
		while ( $self->{content} =~
		    m/ \G \s* \n \s* \# [^\n]* /smxgc ) {
##		    $found_embedded_comments = 1;
		}
		$self->{content} =~ m/ \s* /smxgc;
	    } else {
		pos $self->{content} = $self->{cursor_curr} +
		$offset;
	    }
	    # Localizing cursor_curr and delimiter_start would be
	    # cleaner, but I don't want the old values restored if a
	    # parse error occurs.
	    my $cursor_curr = $self->{cursor_curr};
	    my $delimiter_start = $self->{delimiter_start};
	    $self->{cursor_curr} = pos $self->{content};
	    $self->{delimiter_start} = substr
		$self->{content},
		$self->{cursor_curr},
		1;
	    $self->{trace}
		and warn "Tokenizer found replacement start delimiter '$self->{delimiter_start}' at $self->{cursor_curr}\n";
	    if ( my $s_off = $self->find_matching_delimiter() ) {
		$self->{cursor_modifiers} =
		    $self->{cursor_curr} + $s_off + 1;
		$self->{trace}
		    and warn "Tokenizer found replacement end delimiter at @{[
			$self->{cursor_curr} + $s_off ]}\n";
		$self->{cursor_curr} = $cursor_curr;
		$self->{delimiter_start} = $delimiter_start;
	    } else {
		$self->{trace}
		    and warn 'Tokenizer failed to find replacement',
			"end delimiter starting at $self->{cursor_curr}\n";
		$self->{cursor_curr} = 0;
		# TODO If I were smart enough here I could check for
		# PPI mis-parses like s{foo}
		#                     #{bar}
		#                      {baz}
		# here, doing so if $found_embedded_comments (commented
		# out above) is true. The problem is that there seem to
		# as many mis-parses as there are possible delimiters.
		return $self->__init_error(
		    'Tokenizer found mismatched replacement delimiters',
		);
	    }
	} else {
	    $self->{cursor_modifiers} = $cursor_limit + 1;
	}
	$self->{cursor_limit} = $cursor_limit;
    } else {
	$self->{cursor_curr} = 0;
	return $self->_make_final_token(
	    length( $self->{content} ), TOKEN_UNKNOWN, {
		error	=> 'Tokenizer found mismatched regexp delimiters',
	    },
	);
    }

    {
	# We have to instantiate the trailing tokens now so we can
	# figure out what modifiers are in effect. But we can't
	# index their locations (if desired) because they are being
	# instantiated out of order

	local $self->{index_locations} = 0;

	my @mods = @{ $self->{default_modifiers} };
	pos $self->{content} = $self->{cursor_modifiers};
	local $self->{cursor_curr} = $self->{cursor_modifiers};
	local $self->{cursor_limit} = length $self->{content};
	my @trailing;
	{
	    my $len = $self->find_regexp( qr{ \A [[:lower:]]* }smx );
	    push @trailing, $self->make_token( $len,
		'PPIx::Regexp::Token::Modifier' );
	}
	if ( my $len = $self->find_regexp( qr{ \A \s+ }smx ) ) {
	    push @trailing, $self->make_token( $len,
		'PPIx::Regexp::Token::Whitespace' );
	}
	if ( my $len = $self->find_regexp( qr{ \A .+ }smx ) ) {
	    push @trailing, $self->make_token( $len, TOKEN_UNKNOWN, {
		    error	=> 'Trailing characters after expression',
		} );
	}
	$self->{trailing_tokens} = \@trailing;
	push @mods, $trailing[0]->content();
	$self->{effective_modifiers} =
	    PPIx::Regexp::Token::Modifier::__aggregate_modifiers (
		@mods );
	$self->{modifiers} = [
	    { %{ $self->{effective_modifiers} } },
	];
    }

    $self->{delimiter_finish} = substr
	$self->{content},
	$self->{cursor_limit},
	1;

    push @tokens, $self->make_token( 1,
	'PPIx::Regexp::Token::Delimiter' );

    $self->_set_mode( 'regexp' );

    $self->{find} = undef;

    return @tokens;
}

# Match the initial part of the regexp including any leading white
# space. The initial delimiter is the first thing not consumed, though
# we check it for sanity.
sub __initial_match {
    my ( $self ) = @_;

    $self->find_regexp(
	qr{ \A ( \s* ) ( qr | m | s )? ( \s* ) (?: [^\w\s] ) }smx )
	or return;

    my ( $leading_white, $type, $next_white ) = $self->capture();

    defined $type
	or $type = '';

    $self->{type} = $type;

    my @tokens;

    '' ne $leading_white
	and push @tokens, $self->make_token( length $leading_white,
	'PPIx::Regexp::Token::Whitespace' );
    push @tokens, $self->make_token( length $type,
	'PPIx::Regexp::Token::Structure' );
    '' ne $next_white
	and push @tokens, $self->make_token( length $next_white,
	'PPIx::Regexp::Token::Whitespace' );

    return @tokens;
}

{
    my %extra_parts = (
	s	=> 1,
    );

    # Return the number of extra delimited parts. This will be 0 except
    # for s///, which will be 1.
    sub __number_of_extra_parts {
	my ( $self ) = @_;
	return $extra_parts{$self->{type}} || 0;
    }
}

{
    my @part_class = qw{
	PPIx::Regexp::Structure::Regexp
	PPIx::Regexp::Structure::Replacement
    };

    # Return the classes for the parts of the expression.
    sub __part_classes {
	my ( $self ) = @_;
	my $max = $self->__number_of_extra_parts();
	return @part_class[ 0 .. $max ];
    }
}

sub __PPIX_TOKENIZER__regexp {
    my ( $self, $character ) = @_;

    my $mode = $self->{mode};
    my $handler = '__PPIX_TOKENIZER__' . $mode;

    $self->{cursor_orig} = $self->{cursor_curr};
    foreach my $class ( $self->_known_tokenizers() ) {
	my @tokens = grep { $_ } $class->$handler( $self, $character );
	$self->{trace}
	    and warn $class, "->$handler( \$self, '$character' )",
		" => (@tokens)\n";
	@tokens
	    and return ( map {
		ref $_ ? $_ : $self->make_token( $_,
		    $class ) } @tokens );
    }

    # Find a fallback processor for the character.
    my $fallback = __PACKAGE__->can( '__PPIX_TOKEN_FALLBACK__' . $mode )
	|| __PACKAGE__->can( '__PPIX_TOKEN_FALLBACK__regexp' )
	|| confess "Programming error - unable to find fallback for $mode";
    return $fallback->( $self, $character );
}

*__PPIX_TOKENIZER__repl = \&__PPIX_TOKENIZER__regexp;

sub __PPIX_TOKEN_FALLBACK__regexp {
    my ( $self, $character ) = @_;

    # As a fallback in regexp mode, any escaped character is a literal.
    if ( $character eq '\\'
	&& $self->{cursor_limit} - $self->{cursor_curr} > 1
    ) {
	return $self->make_token( 2, TOKEN_LITERAL );
    }

    # Any normal character is unknown.
    return $self->make_token( 1, TOKEN_UNKNOWN, {
	    error	=> 'Tokenizer found unexpected literal',
	},
    );
}

sub __PPIX_TOKEN_FALLBACK__repl {
    my ( $self, $character ) = @_;

    # As a fallback in replacement mode, any escaped character is a literal.
    if ( $character eq '\\'
	&& defined ( my $next = $self->peek( 1 ) ) ) {

	if ( $self->interpolates() || $next eq q<'> || $next eq '\\' ) {
	    return $self->make_token( 2, TOKEN_LITERAL );
	}
	return $self->make_token( 1, TOKEN_LITERAL );
    }

    # So is any normal character.
    return $self->make_token( 1, TOKEN_LITERAL );
}

sub __PPIX_TOKENIZER__finish {
    my ( $self ) = @_;		# $character unused

    $self->{cursor_limit} > length $self->{content}
	and confess "Programming error - ran off string";

    my @tokens = $self->make_token( length $self->{delimiter_finish},
	'PPIx::Regexp::Token::Delimiter' );

    if ( $self->{cursor_curr} == $self->{cursor_modifiers} ) {

	# We are out of string. Add the trailing tokens (created when we
	# did the initial bracket scan) and close up shop.

	push @tokens, $self->_get_trailing_tokens();

	$self->_set_mode( 'kaput' );

    } else {

	# Clear the cookies, because we are going around again.
	$self->{cookie} = {};

	# Move the cursor limit to just before the modifiers.
	$self->{cursor_limit} = $self->{cursor_modifiers} - 1;

	# If the preceding regular expression was bracketed, we need to
	# consume possible whitespace and find another delimiter.

	if ( $self->close_bracket( $self->{delimiter_start} ) ) {
	    my $accept;
	    # If we are bracketed, there can be honest-to-God Perl
	    # comments between the regexp and the replacement, not just
	    # regexp comments. As of version 1.220, PPI does not get
	    # this parse right, but if we can handle this is a string,
	    # then we will Just Work when PPI gets itself straight.
	    while ( $self->find_regexp(
		    qr{ \A ( \s* \n \s* ) ( \# [^\n]* \n ) }smx ) ) {
		my ( $white_space, $comment ) = $self->capture();
		push @tokens, $self->make_token(
		    length $white_space,
		    'PPIx::Regexp::Token::Whitespace',
		), $self->make_token(
		    length $comment,
		    'PPIx::Regexp::Token::Comment',
		);
	    }
	    $accept = $self->find_regexp( qr{ \A \s+ }smx )
		and push @tokens, $self->make_token(
		$accept, 'PPIx::Regexp::Token::Whitespace' );
	    my $character = $self->peek();
	    $self->{delimiter_start} = $character;
	    push @tokens, $self->make_token(
		1, 'PPIx::Regexp::Token::Delimiter' );
	    $self->{delimiter_finish} = substr
		$self->{content},
		$self->{cursor_limit} - 1,
		1;
	}

	if ( $self->modifier( 'e*' ) ) {
	    # With /e or /ee, the replacement portion is code. We make
	    # it all into one big PPIx::Regexp::Token::Code, slap on the
	    # trailing delimiter and modifiers, and return it all.
	    push @tokens, $self->make_token(
		$self->{cursor_limit} - $self->{cursor_curr},
		'PPIx::Regexp::Token::Code',
		{ perl_version_introduced => MINIMUM_PERL },
	    );
	    $self->{cursor_limit} = length $self->{content};
	    push @tokens, $self->make_token( 1,
		'PPIx::Regexp::Token::Delimiter' ),
		$self->_get_trailing_tokens();
	    $self->_set_mode( 'kaput' );
	} else {
	    # Put our mode to replacement.
	    $self->_set_mode( 'repl' );
	}

    }

    return @tokens;

}

# To common processing on trailing tokens.
sub _get_trailing_tokens {
    my ( $self ) = @_;
    if ( $self->{index_locations} ) {
	# We turned off index_locations when these were created, because
	# they were done out of order. Fix that now.
	foreach my $token ( @{ $self->{trailing_tokens} } ) {
	    $self->_update_location( $token );
	}
    }
    return @{ delete $self->{trailing_tokens} };
}

1;

__END__