view release on metacpan or  search on metacpan

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

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

	} elsif ($token =~ /e/ && $tokens[-2] =~ /^s/) {
	  if ($regex_type eq "B") {  # s///, tr///, y///
	    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,$t2+1);
	    push @contexts, "regular expression b /$terminator/";
	    $i -= length($token) + length($regex) - $t2 - 1;
	  }
	}

      } else {
	push @contexts, "alphanumeric literal";   # bareword? name? label? keyword?
      }
      $i = $i -1 + length $token;

    } elsif (($token = find_token_keyword($Q)) && !$sigil) {

      push @tokens, $token;
      push @contexts, "operator";
      $i = $i - 1 + length $token;

    } else {

      push @tokens, $_;

      if ($sigil) {
	push @contexts, "name";
      } elsif (/\s/) {
	push @contexts, "whitespace";
      } elsif (/;/ && !$sigil) {
	push @contexts, "end of statement";
      } elsif (/\//) {
	push @contexts, "operator or misanalyzed regex";
      } elsif (/[\+\-\*\/\%\^\|\&\!\~\?\:\.]/) {
	push @contexts, "operator";

      } elsif (/\{/ && $sigil) {
	push @contexts, "name container";
      } elsif (/\}/ && STRPOS("name contained",@contexts) > STRPOS("name decontainer",@contexts)) {
	push @contexts, "name decontainer";

      } else {
	push @contexts, "unknown";
      }
    }

    $sigil = 0;
  }

  if ($DEBUG) {
    print "- " x 20,"\n";
    my @c = @contexts;
    foreach $token (@tokens) {
      my $cc = shift @c;
      print $token,"\t",$cc,"\n";