File Coverage

blib/lib/Text/MicroMason/Base.pm

Criterion	Covered	Total	%
statement	137	143	95.8
branch	48	72	66.6
condition	7	11	63.6
subroutine	25	27	92.5
pod	17	20	85.0
total	234	273	85.7

package Text::MicroMason::Base;

use strict;
require Carp;

######################################################################

######################################################################

use Class::MixinFactory -hasafactory;
for my $factory ( (__PACKAGE__)->mixin_factory ) {
  $factory->base_class( "Text::MicroMason::Base" );
  $factory->mixin_prefix( "Text::MicroMason" );
}

######################################################################

######################################################################

sub new {
  my $callee = shift;
  my ( @traits, @attribs );
  while ( scalar @_ ) {
    if (  $_[0] =~ /^\-(\w+)$/ ) {
      push @traits, $1;
      shift;
    } else {
      push @attribs, splice(@_, 0, 2);
    }
  }
  if ( scalar @traits ) {
    die("Adding moxins to an existing class not supported yet!")
	unless ( $callee eq __PACKAGE__ );
    $callee->class( @traits )->create( @attribs )
  } else {
    $callee->create( @attribs )
  }
}

######################################################################

# $mason = $class->create( %options );
# $clone = $object->create( %options );
sub create {
  my $referent = shift;
  if ( ! ref $referent ) {
    bless { $referent->defaults(), @_ }, $referent;
  } else {
    bless { $referent->defaults(), %$referent, @_ }, ref $referent;
  }
}

sub defaults {
  return ()
}

######################################################################

######################################################################

# $code_ref = $mason->compile( text => $template, %options );
# $code_ref = $mason->compile( file => $filename, %options );
# $code_ref = $mason->compile( handle => $filehandle, %options );
sub compile {
    my ( $self, $src_type, $src_data, %options ) = @_;

    ($self, $src_type, $src_data) = $self->prepare($src_type, $src_data,%options);

    my $code = $self->interpret( $src_type, $src_data );

    unless ( $self->eval_sub($code) ) {
        ref($@) and die $@;
        $self->croak_msg( "MicroMason compilation failed: $@\n" . _number_lines($code) . "\n" );
    }

}

# Internal helper to number the lines in the compiled template when compilation croaks
sub _number_lines {
    my $code = shift;

    my $n = 0;
    return join("\n", map { sprintf("%4d  %s", $n++, $_) } split(/\n/, $code)).
        "\n** Please use Text::MicroMason->new\(-LineNumbers\) for better diagnostics!";
}


######################################################################

# $result = $mason->execute( code => $subref, @arguments );
# $result = $mason->execute( $src_type, $src_data, @arguments );
# $result = $mason->execute( $src_type, $src_data, \%options, @arguments );
sub execute {
  my $self = shift;
  my $sub = ( $_[0] eq 'code' ) ? do { shift; shift } : $self->compile( shift, shift, ref( $_[0] ) ? %{ shift() } : () );
  unless ($sub) {
      ref($@) and die $@;
      $self->croak_msg("MicroMason compilation failed: $@");
  }
  &$sub( @_ );
}

######################################################################

######################################################################

# ($self, $src_type, $src_data) = $self->prepare($src_type, $src_data, %options)
sub prepare {
  my ( $self, $src_type, $src_data, %options ) = @_;
  $self = $self->create( %options ) if ( scalar keys %options );
  return ( $self, $src_type, $src_data );
}

######################################################################

# $perl_code = $mason->interpret( $src_type, $src_data );
sub interpret {
  my ( $self, $src_type, $src_data ) = @_;
  my $template = $self->read( $src_type, $src_data );
  my @tokens = $self->lex( $template );
  my $code = $self->assemble( @tokens );

  # Source file and line number
  my $source_line = $self->source_file_line_label( $src_type, $src_data );

  return $source_line . "\n" . $code;
}

# $line_number_comment = $mason->source_file_line_label( $src_type, $src_data );
sub source_file_line_label {
    my ( $self, $src_type, $src_data ) = @_;

    if ( $src_type eq 'file' ) {
        return qq(# line 1 "$src_data");
    }

    my @caller;
    my $call_level;
    do { @caller = caller( ++ $call_level ) }
        while ( $caller[0] =~ /^Text::MicroMason/ or $self->isa($caller[0]) );
    my $package = ( $caller[1] || $0 );
    qq{# line 1 "text template (compiled at $package line $caller[2])"}
}


######################################################################

# $code_ref = $mason->eval_sub( $perl_code );
sub eval_sub {
  my $m = shift;
  package Text::MicroMason::Commands;
  eval( shift )
}

######################################################################

######################################################################

# $template = $mason->read( $src_type, $src_data );
sub read {
  my ( $self, $src_type, $src_data ) = @_;

  my $src_method = "read_$src_type";
  $self->can($src_method)
      or $self->croak_msg("Unsupported source type '$src_type'");
  $self->$src_method( $src_data );
}

# $template = $mason->read_text( $template );
sub read_text {
  ref($_[1]) ? $$_[1] : $_[1];
}

# $contents = $mason->read_file( $filename );
sub read_file {
  my ( $self, $file ) = @_;
  local *FILE;
  open FILE, "$file" or $self->croak_msg("MicroMason can't open $file: $!");
  local $/ = undef;
  local $_ = ;
  close FILE or $self->croak_msg("MicroMason can't close $file: $!");;
  return $_;
}

# $contents = $mason->read_handle( $filehandle );
sub read_handle {
  my ( $self, $handle ) = @_;
  my $fh = (ref $handle eq 'GLOB') ? $handle : $$handle;
  local $/ = undef;
  <$fh>
}

######################################################################

# @token_pairs = $mason->lex( $template );
sub lex {
  my $self = shift;
  local $_ = "$_[0]";
  my @tokens;
  my $lexer = $self->can('lex_token')
    or $self->croak_msg('Unable to lex_token(); must select a syntax mixin');
  # warn "Lexing: " . pos($_) . " of " . length($_) . "\n";
  until ( /\G\z/gc ) {
    my @parsed = &$lexer( $self ) or
	/\G ( .{0,20} ) /gcxs
	  && die "MicroMason parsing halted at '$1'\n";
    push @tokens, @parsed;
  }
  return @tokens;
}

# ( $type, $value ) = $mason->lex_token();
sub lex_token {
  die "The lex_token() method is abstract and must be provided by a subclass";
}

######################################################################

######################################################################

# Text elements used for subroutine assembly
sub assembler_rules {
  template => [ qw( $sub_start $init_errs $init_output
		    $init_args @perl $return_output $sub_end ) ],

  # Subroutine scafolding
  sub_start  => 'sub { ',
  sub_end  => '}',
  init_errs =>
    'local $SIG{__DIE__} = sub { ref($_[0]) and die $_[0];  die "MicroMason execution failed: ", @_ };',

  # Argument processing elements
  init_args => 'my %ARGS = @_ if ($#_ % 2);',

  # Output generation
  init_output => sub { my $m = shift; my $sub = $m->{output_sub} ? '$m->{output_sub}' : 'sub {push @OUT, @_}'; 'my @OUT; my $_out = ' . $sub . ';' },
  add_output => sub { my $m = shift; $m->{output_sub} ? '&$_out' : 'push @OUT,' },
  return_output => 'join("", @OUT)',

  # Mapping between token types
  text_token => 'perl OUT( QUOTED );',
  expr_token => "perl OUT( \"\".do{\nTOKEN\n} );",
    # the "". here forces string context, and should hopefully make
    # 'uninitialized' warnings appear closer to their source, rather
    # than at the big join "", @OUT; at the end
  file_token => "perl OUT( \$m->execute( file => do {\nTOKEN\n} ) );",
    # Note that we need newline after TOKEN here in case it ends with a comment.
}

sub assembler_vars {
  my $self = shift;
  my %assembler = $self->assembler_rules();

  my @assembly = @{ delete $assembler{ template } };

  my %token_map = map { ( /^(.*?)_token$/ )[0] => delete $assembler{$_} }
					    grep { /_token$/ } keys %assembler;

  my %fragments = map { $_ => map { ref($_) ? &{$_}( $self ) : $_ } $assembler{$_} } keys %assembler;

  return( \@assembly, \%fragments, \%token_map );
}

# $perl_code = $mason->assemble( @tokens );
sub assemble {
  my $self = shift;
  my @tokens = @_;

  my ( $order, $fragments, $token_map ) = $self->assembler_vars();

  my %token_streams = map { $_ => [] } map { ( /^\W?\@(\w+)$/ ) } @$order;

  while ( scalar @tokens ) {
    my ( $type, $token ) = splice( @tokens, 0, 2 );

    unless ( $token_streams{$type} or $token_map->{$type} ) {
      my $method = "assemble_$type";
      my $sub = $self->can( $method )
	or $self->croak_msg( "Unexpected token type '$type': '$token'" );
      ($type, $token) = &$sub( $self, $token );
    }

    if ( my $typedef = $token_map->{ $type } ) {
      # Perform token map substitution in a single pass so that uses of
      # OUT in the token text are not improperly converted to output calls.
      #   -- Simon, 2009-11-14
      my %substitution_map = (
        'OUT'    => $fragments->{add_output},
        'TOKEN'  => $token,
        'QUOTED' => "qq(\Q$token\E)",
      );
      $typedef =~ s/\b(OUT|TOKEN|QUOTED)\b/$substitution_map{$1}/g;

      ( $type, $token ) = split ' ', $typedef, 2;
    }

    my $ary = $token_streams{$type}
	or $self->croak_msg( "Unexpected token type '$type': '$token'" );

    push @$ary, $token
  }

  join( "\n",  map {
    /^(\W+)(\w+)$/ or $self->croak_msg("Can't assemble $_");
    if ( $1 eq '$' ) {
      $fragments->{ $2 }
    } elsif ( $1 eq '@' ) {
      @{ $token_streams{ $2 } }
    } elsif ( $1 eq '!@' ) {
      reverse @{ $token_streams{ $2 } }
    } elsif ( $1 eq '-@' ) {
      ()
    } else {
      $self->croak_msg("Can't assemble $_");
    }
  } @$order );
}

######################################################################

######################################################################

sub croak_msg {
  local $Carp::CarpLevel = 2;
  shift and Carp::croak( ( @_ == 1 ) ? $_[0] : join(' ', map _printable(), @_) )
}

my %Escape = (
  ( map { chr($_), unpack('H2', chr($_)) } (0..255) ),
  "\\"=>'\\', "\r"=>'r', "\n"=>'n', "\t"=>'t', "\""=>'"'
);

# $special_characters_escaped = _printable( $source_string );
sub _printable {
  local $_ = scalar(@_) ? (shift) : $_;
  return "(undef)" unless defined;
  s/([\r\n\t\"\\\x00-\x1f\x7F-\xFF])/\\$Escape{$1}/sgo;
  /[^\w\d\-\:\.\']/ ? "q($_)" : $_;
}

######################################################################


sub cache_key {
    my $self = shift;
    my ($src_type, $src_data, %options) = @_;

    return $src_data;
}


1;

__END__