view release on metacpan or  search on metacpan

lib/Acme/AsciiArtinator.pm  view on Meta::CPAN

  # regex is expected following an operator,
  #       at the beginning of a statement
  # divide is expected following a scalar,
  #       or any token that could complete an expression

  my $c = $#contexts;
  $c-- while $contexts[$c] eq "whitespace";
  return "regex" if $contexts[$c] eq "operator";
  return "regex" if $tokens[$c] eq ";" && $tokens[$c-1] ne "SIGIL";

  return "divide";
}

sub tokenize_code {
  my ($INPUT) = @_;
  local $" = '';
  my @INPUT = grep { /[^\n]/ } split //, $INPUT;

  # tokens are:
  #   quotes strings
  #   numeric literals
  #   regular expression specifications
  #       except with //x and s///x
  #   alphanumeric strings
  #   punctuation strings from @token_keywords
  #

  my ($i, $j, $Q, @tokens, $token, $sigil, @contexts, @blocks);

  $sigil = 0;
  for ($i = 0; $i < @INPUT; $i++) {
    $_ = $INPUT[$i];
    $Q = "@INPUT[$i..$#INPUT]";

    print STDERR "\$Q = ", substr($Q,0,8), "... SIGIL=$sigil\n" if $_ eq "q" && $DEBUG;

    # $#  could be "the output format of printed numbers"
    # or it could be the start of an expression like  $#X  or  $#{@$X}
    # in the latter case we need $# + one more token to be contiguous
    if ($Q =~ /^\$\#\{/ || $Q =~ /^\$\#\w+/) {
      $token = $&;
      push @tokens, $token;
      push @contexts, "\$# operator";
      $i = $i - 1 + length $token;
      $sigil = 0;
      next;
    }


    if ($sigil{$_} && $Q !~ /^\$\#/) {
      $sigil = $sigil{$_};
      push @tokens, $_;
      push @contexts, "SIGIL";
      next;
    }

    if (!$sigil && ($_ eq "'" || $_ eq '"' ||
		    $_ eq "/" && regex_or_divide(\@tokens,\@contexts) eq "regex")) {
      # walk through @INPUT looking for the end of the string
      # manage a boolean $escaped variable handy to allow
      # escaped strings inside strings.

      my $escaped = 0;
      my $terminator = $_;
      for($j = $i + 1; $j <= $#INPUT; $j++) {
	if ($INPUT[$j] eq "\\") {
	  $escaped = !$escaped;
	  next;
	}
	last if $INPUT[$j] eq $terminator && !$escaped;
	$escaped = 0;
      }
      my $token = "@INPUT[$i..$j]";

      if ($_ eq "/" && (length $token > 30 || $j >= $#INPUT)) {
	# this regex is pretty long. Maybe we made a mistake.
	my $toke2 = find_token_keyword($Q) || "/";
	$token = $toke2;
	$_ = "/!";
      }


      push @tokens, $token;
      if ($_ eq "/!") {
	push @contexts, "misanalyzed regex or operator";
      } elsif ($_ eq "/") {
	push @contexts, "regular expression C ///";
      } else {
	push @contexts, "quoted string";
      }
      $i = $j;

    } elsif (!$sigil && $Q =~ /^[0-9]*\.{0,1}[0-9]+([eE][-+]?[0-9]+)?/) {

      # if first char starts a numeric literal, include all characters
      # from the number in the token

      

      $token = $&;
      push @tokens, $token;
      push @contexts, "numeric literal A";
      $i = $i - 1 + length $token;

    } elsif (!$sigil && $Q =~ /^[0-9]+\.{0,1}[0-9]*([eE][-+]?[0-9]+)?/) {

      $token = $&;
      push @tokens, $token;
      push @contexts, "numeric literal B";
      $i += length $token;

    } elsif (!$sigil && ($Q =~ /^m\W/ || $Q =~ /^qr\W/ || $Q =~ /^q[^\w\s]/ || $Q =~ /^qq\W/)) {
      $j = $Q =~ /^q[rq]\W/ ? $i + 3 : $i + 2;

      my $terminator = $INPUT[$j - 1];
      $terminator =~ tr!{}<>[]{}()!}{><][}{)(!;


      my $escaped = 0;
      for(; $j <= $#INPUT; $j++) {
	if ($INPUT[$j] eq "\\") {
	  $escaped = !$escaped;
	  next;
	}
	last if $INPUT[$j] eq $terminator && !$escaped;
	# XXX - if regex has 'x' modifier,
	# then 
	$escaped = 0;
      }
      push @tokens, "@INPUT[$i..$j]";
      push @contexts, "regular expression A /$terminator/";
      $i = $j;

    } elsif (!$sigil && ($Q =~ /^s\W/ || $Q =~ /^y\W/ || $Q =~ /^tr\W/)) {
      $j = $_ eq "t" ? $i + 3 : $i + 2;
      my $terminator = $INPUT[$j-1];
      $terminator =~ tr!{}<>[]{}()!}{><][}{)(!;
      my $escaped = 0;
      my $terminators_found = 0;
      for (; $j <= $#INPUT; $j++) {
	if ($INPUT[$j] eq "\\") {
	  $escaped = !$escaped;
	  next;
	}
	if ($INPUT[$j] eq $terminator && !$escaped) {
	  if ($terminators_found++) {
	    last;
	  }
	}
	$escaped = 0;
      }
      push @tokens, "@INPUT[$i..$j]";
      push @contexts, "regular expression B /$terminator/";
      $i = $j;

    } elsif ($Q =~ /^[a-zA-Z_]\w*/) {


      $token = $&;

      # "T"x90 should be ["T",x,90] not ["T",x90]
      #  x90 should be x,90 when previous token is a scalar
      if ($token =~ /^x\d+$/) {
	if ($tokens[-1] =~ /^[\'\"]/ || $tokens[-1] eq ")"
	   || $contexts[-1] =~ /name/) {
	  $token = "x";
	}
      }

      push @tokens, $token;
      if ($sigil) {
	push @contexts, "name";
      } elsif ($contexts[-1] =~ /regular expression ([ABC]) \/(.)\//) {
	push @contexts, "regular expression modifier";
	my $regex_type = $1;
	my $terminator = $2;

	# with some modifiers we can be more flexible with the earlier tokens ...
	#     e - second pattern is an expression that can be flexible
	#     x - first and/or second pattern can contain whitespace

	if (0 && $token =~ /e/ && $token =~ /x/ && $tokens[-2] =~ /^s/) {
	  $DB::single=1;
	  pop @tokens;
	  pop @contexts;
	  my $regex = pop @tokens;
	  my $regex_context = pop @contexts;
	  my $terminator2 = $terminator;
	  $terminator2 =~ tr/])}>/[({</; # >})]
	  my $t1 = index($regex,$terminator2);
	  my $t2 = index($regex,$terminator,$t1+1);

	  push @tokens, substr($regex,0,$t1+1);
	  push @contexts, "regular expression x /$terminator/";

	  for (my $t=$t1+1; $t<=$t2; $t++) {
	    if (substr($regex,$t,1) =~ /\S/) {
	      push @tokens, substr($regex,$t,1);
	      push @contexts, "content of regex/x";
	    }
	  }
	  $i -= length($token) + length($regex) - $t2 - 1;

	  # positions $i to the start of the 2nd pattern,
          # which can be tokenized as a perl expression.
          # Hopefully the terminator can be recognized

	} elsif ($token =~ /x/) {
	  pop @tokens;
	  pop @contexts;