File Coverage

blib/lib/Convert/Transcribe.pm

Criterion	Covered	Total	%
statement	75	76	98.6
branch	17	20	85.0
condition			n/a
subroutine	10	10	100.0
pod	0	5	0.0
total	102	111	91.8

package Convert::Transcribe;

use 5.005;
use strict;
use Carp;

require Exporter;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);

@ISA = qw(Exporter);

%EXPORT_TAGS = ();

@EXPORT_OK = ();

@EXPORT = ();

$VERSION = '0.02';

sub new {
    my $class = shift;
    my $self = {};
    bless($self, $class);
    if (defined($_[0])) {
      if ($_[0] =~ /[\n\r]/) {
	fromstring($self, $_[0]);
      } else {
	fromfile($self, $_[0]);
      }
    }
    return $self;
}

sub fromfile {
  my $self = shift;
  my ($filename) = @_;
  open TLT, "<$filename" or croak "Cannot open $filename";
  while () {
    chomp;
    push @{$self->{DATA}}, $_;
  }
  close TLT;
  _genfunc($self);
}

sub fromstring {
  my $self = shift;
  my ($string) = @_;
  chomp($string);
  @{$self->{DATA}} = split(/[\r\n]+/, $string);
  _genfunc($self);
}


sub _genfunc {
  my $self = shift;
  my (@r, $t, $neg, $ch, $sub, @cond, $i);

  $sub = "my \$tr = '';\nwhile (length) {\n";
  @cond = ();

  foreach (@{$self->{DATA}}) {
    ($t, $neg) = ('', 0);
    s/\#.*//;
    s/([\'\"\/])/\\$1/g;
    while (/[\<\>]/) {
      s/([\<\>][^\<\>]+)// and push @cond, [split(' ', $1)];
    }
    @r = split;
    if (@r == 2) {

      foreach $i (@cond) {

	$t = shift @$i;

	if ($i->[0] eq '!') {
	  $ch = '!';
	  shift @$i;
	} else {
	  $ch = '=';
	}

	my $reg = '(';  my $del = '';
	foreach (@$i) {
	  $reg .= $del;

	  if ($_ eq '$') {
	    $reg .= ($t eq '>'? '\s|$': '^|\s');
	  } else {
	    $reg .= $_;
	  }
	  $del = '|';
	}
	$reg .= ')';

	if ($t eq '<') {
	  $sub .= " \$tr $ch~ /$reg\$/ and ";
	} elsif ($t eq '>') {
	  $sub .= " /^$r[0](?$ch$reg)/ and ";
	} else {
	  carp "Strange condition: " . join(' ', @$i), "\n";
	}
      }
      $sub .= " s/^$r[0]// and \$tr .= '$r[1]' and next;\n";
      @cond = ();
    }
  }
  $sub .= " s/^(.|\\n)//; \$tr .= \$1;\n  }\nreturn \$tr;\n";

  $self->{SUB} = $sub;
}

sub transcribe {
  my $self = shift;

  local ($_) = shift;
  eval $self->{SUB};
}

sub generated_code {
  my $self = shift;

  return $self->{SUB};
}

1;
__END__