File Coverage

blib/lib/Devel/Tokenizer/C.pm

Criterion	Covered	Total	%
statement	156	159	98.1
branch	77	86	89.5
condition	32	37	86.4
subroutine	14	14	100.0
pod	3	3	100.0
total	282	299	94.3

################################################################################
#
# MODULE: Devel::Tokenizer::C
#
################################################################################
#
# DESCRIPTION: Generate C source for fast keyword tokenizer
#
################################################################################
#
# $Project: /Devel-Tokenizer-C $
# $Author: mhx $
# $Date: 2008/12/13 16:03:38 +0100 $
# $Revision: 16 $
# $Source: /lib/Devel/Tokenizer/C.pm $
#
################################################################################
#
# Copyright (c) 2002-2008 Marcus Holland-Moritz. All rights reserved.
# This program is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
#
################################################################################

package Devel::Tokenizer::C;

use 5.005_03;
use strict;
use Carp;
use vars '$VERSION';

$VERSION = do { my @r = '$Snapshot: /Devel-Tokenizer-C/0.08 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' };

my %DEF = (
  CaseSensitive => 1,
  Comments      => 1,
  Indent        => '  ',
  MergeSwitches => 0,
  Strategy      => 'ordered',   #  wide, narrow, ordered
  StringLength  => '',
  TokenEnd      => "'\\0'",
  TokenFunc     => sub { "return $_[0];\n" },
  # TokenSort     => sub { $_[0] cmp $_[1] },             # TODO?
  TokenString   => 'tokstr',
  UnknownLabel  => 'unknown',
  UnknownCode   => undef,
);

sub new
{
  my $class = shift;
  my %opt = @_;
  for (keys %opt) { exists $DEF{$_} or croak "Invalid option '$_'" }
  if (exists $opt{TokenFunc}) {
    ref $opt{TokenFunc} eq 'CODE'
        or croak "Option TokenFunc needs a code reference";
  }
  my %self = (
    %DEF, @_,
    __tcheck__ => {},
    __tokens__ => {},
    __backup__ => [],
    __maxlen__ => 0,
  );
  if ($self{StringLength} eq '' and $self{Strategy} ne 'ordered') {
    croak "Cannot use Strategy '$self{Strategy}' without StringLength";
  }
  bless \%self, $class;
}

sub add_tokens
{
  my $self = shift;
  my($tokens, $pre) = ref $_[0] eq 'ARRAY' ? @_ : \@_;
  for (@$tokens) {
    my $tok = $self->{CaseSensitive} ? $_ : lc;
    exists $self->{__tcheck__}{$tok}
        and carp $self->{__tcheck__}{$tok} eq ($pre || '')
                 ? "Multiple definition of token '$_'"
                 : "Redefinition of token '$_'";
    $self->{__tcheck__}{$tok} = $self->{__tokens__}{$_} = $pre || '';
    my $len = length __quotecomment__($_);
    $self->{__maxlen__} = $len if $len > $self->{__maxlen__};
  }
  $self;
}

sub generate
{
  my $self = shift;
  my %options = (Indent => '', @_);
  my $IND = $options{Indent};
  my $I = $self->{Indent};

  if ($self->{StringLength}) {
    my @tokens;
    for my $t (keys %{$self->{__tokens__}}) {
      $tokens[length $t]{$t} = $self->{__tokens__}{$t};
    }

    my $rv = <
${IND}switch ($self->{StringLength})
$IND\{
EOS

    for my $len (1 .. $#tokens) {
      $tokens[$len] or next;
      my $count = keys %{$tokens[$len]};
      my $switch = $self->__makeit__($IND.$I.$I, $self->__order__($tokens[$len]), 0, 0, $tokens[$len]);
      $rv .= <
$IND${I}case $len: /* $count tokens of length $len */
$switch
EOS
    }

    my $unk = $self->__unknown__("$IND$I$I");

    $rv .= <
$IND${I}default:
$unk
EOS

    $rv .= "$IND}\n"
  }
  else {
    return $self->__makeit__($IND, undef, 0, 0, $self->{__tokens__});
  }
}

sub __order__
{
  my($self, $tok) = @_;
  my @hist;

  return undef if $self->{Strategy} eq 'ordered';

  for my $k (keys %$tok) {
    my @key = ($self->{CaseSensitive} ? $k : uc $k) =~ /(.)/g;
    for my $i (0 .. $#key) {
      $hist[$i]{$key[$i]}++;
    }
  }
  for my $i (0 .. $#hist) {
    $hist[$i]{ix} = $i;
  }

  if ($self->{Strategy} eq 'wide') {
    @hist = sort { keys %$b <=> keys %$a } @hist;
  }
  elsif ($self->{Strategy} eq 'narrow') {
    @hist = sort { keys %$a <=> keys %$b } @hist;
  }
  else {
    croak "Invalid Strategy '$self->{Strategy}'";
  }

  return [map $_->{ix}, @hist];
}

sub __commented__
{
  my($self, $code, $comment) = @_;
  return "$code\n" unless $self->{Comments};
  sprintf "%-50s/* %-$self->{__maxlen__}s */\n", $code, __quotecomment__($comment);
}

sub __unknown__
{
  my($self, $indent) = @_;
  my $code = defined $self->{UnknownCode} ? $self->{UnknownCode}
                                          : "goto $self->{UnknownLabel};";
  $code =~ s/\s+$//;
  $code =~ s/^/$indent/m;
  return $code;
}

sub __makeit__
{
  my($self, $IND, $order, $level, $pre_flag, $t, %tok) = @_;
  my $I = $self->{Indent};

  %$t or return '';

  if (keys(%$t) == 1) {
    my($token) = keys %$t;
    my($rvs,$code);
    my $unknown = '';

    if ($level > length $token) {
      $rvs = $self->__commented__($IND.'{', $token);
      $code = $self->{TokenFunc}->($token);
      $code =~ s/^/$IND$I/mg;
    }
    else {
      my @chars = $token =~ /(.)/g;
      my $cmp = join " &&\n$IND$I$I",
                map { $_->[1] } sort { $a->[0] <=> $b->[0] } map {
                  my $p = defined $order ? $order->[$_] : $_;
                  [$p, $self->__chr2cmp__($p, "'".__quotechar__($chars[$p])."'")];
                } $level .. $#chars;

      if (defined $self->{TokenEnd} and not $self->{StringLength}) {
        $level = @chars;
        $cmp and $cmp .= " &&\n$IND$I$I";
        $cmp .= $self->{TokenString} . "[$level] == $self->{TokenEnd}";
      }

      $unknown = "\n" . $self->__unknown__($IND) . "\n" if $cmp;

      $rvs = ($cmp ? $IND . "if ($cmp)\n" : '') .  $self->__commented__($IND.'{', $token);

      $code = $self->{TokenFunc}->($token);
      $code =~ s/^/$IND$I/mg;
    }

    return "$rvs$code$IND}\n$unknown";
  }

  for my $n (keys %$t) {
    my $c = __quotechar__(substr $n, (defined $order ? $order->[$level] : $level), 1)
            or defined $self->{TokenEnd} or next;
    $tok{$c ne '' ? ($self->{CaseSensitive} || $c !~ /^[a-zA-Z]$/ ? "'$c'" : "'\U$c\E'")
                  : $self->{TokenEnd}}{$n} = $t->{$n};
  }

  my $pos = defined $order ? $order->[$level] : $level;
  my $bke = '';
  my $rvs = '';
  my $nlflag = 0;

  if (keys %tok > 1 or !$self->{MergeSwitches}) {
    if (@{$self->{__backup__}}) {
      my $cmp = join " &&\n$IND$I$I",
                map { $_->[1] } sort { $a->[0] <=> $b->[0] }
                @{$self->{__backup__}};

      $rvs .= $IND."if ($cmp)\n".$IND."{\n";
      $bke = "$IND}\n";

      $IND .= $I;

      @{$self->{__backup__}} = ();
    }

    $rvs .= $IND."switch ($self->{TokenString}\[$pos])\n".$IND."{\n";
  }
  else {
    $bke = "\n" . $self->__unknown__($IND) . "\n" unless @{$self->{__backup__}};
    push @{$self->{__backup__}}, [$pos, $self->__chr2cmp__($pos, keys %tok)];
  }

  for my $c (sort keys %tok) {
    my($clear_pre_flag, %seen) = 0;
    my @pre = grep !$seen{$_}++, values %{$tok{$c}};

    $nlflag and $rvs .= "\n";

    if( $pre_flag == 0 && @pre == 1 && $pre[0] ) {
      $rvs .= "#if $pre[0]\n";
      $pre_flag = $clear_pre_flag = 1;
    }

    if (keys %tok > 1 or !$self->{MergeSwitches}) {
      $rvs .= $self->{CaseSensitive} || $c !~ /^'[a-zA-Z]'$/
            ? $IND.$I."case $c:\n"
            : $IND.$I."case \U$c\E:\n"
            . $IND.$I."case \L$c\E:\n";

      $rvs .= $self->__makeit__($IND.$I.$I, $order, $level+1, $pre_flag, $tok{$c});
    }
    else {
      $rvs .= $self->__makeit__($IND, $order, $level+1, $pre_flag, $tok{$c});
    }

    if ($clear_pre_flag) {
      my $cmt = $self->{Comments} ? " /* $pre[0] */" : '';
      $rvs .= "#endif$cmt\n";
      $pre_flag = 0;
    }

    $nlflag = 1;
  }

  if (keys %tok > 1 || !$self->{MergeSwitches}) {
    my $unk = $self->__unknown__("$IND$I$I");

    $unk = "$IND${I}default:\n$unk\n" if $unk;

    return <
$rvs
$unk$IND}
EOS
  }
  else {
    return $rvs . $bke;
  }
}

sub __quotechar__
{
  my $str = shift;
  $str =~ s/(['\\])/\\$1/g;
  return __quotecomment__($str);
}

sub __quotecomment__
{
  my $str = shift;
  for my $c (qw( a b f n r t )) {
    my $e = eval qq("\\$c");
    $str =~ s/$e/\\$c/g;
  }
  $str =~ s/([\x01-\x1F])/sprintf "\\%o", ord($1)/eg;
  return $str;
}

sub __chr2cmp__
{
  my($self, $p, $c) = @_;
  $self->{CaseSensitive} || $c !~ /^'[a-zA-Z]'$/
  ? $self->{TokenString}."[$p] == $c"
  : '(' . $self->{TokenString} . "[$p] == \U$c\E || "
        . $self->{TokenString} . "[$p] == \L$c\E)";
}

1;

__END__