File Coverage

blib/lib/Parse/Tinymush.pm

Criterion	Covered	Total	%
statement	156	202	77.2
branch	60	100	60.0
condition	25	45	55.5
subroutine	19	21	90.4
pod	2	12	16.6
total	262	380	68.9

package Parse::Tinymush;

use 5.006;
use strict;
use warnings;

our $VERSION = '1.01';

use constant FN_VARARG => -1;

use constant CODE_REF => 0;
use constant ARG_COUNT => 1;
use constant FNC_FLAGS => 2;

use constant FNC_NO_FLAGS => 0;
use constant FNC_PASS_NAME => 1;

my $options = {
  debug => 0,
  space_compresion => 1,
};

sub new {
  my ($class, %args) = @_;

  my $self = {
    brace_depth => 0,
    func_depth => 0,
    functions => $args{functions} || {},
    options => $options,
    output => '',
    string => '',
    temp => '',
    variables => $args{variables} || {},
  };

  if ( exists $args{options} ) {
    foreach my $key ( keys %{ $args{options} } ) {
      return if !exists $self->{options}->{$key};
      $self->{options}->{$key} = $args{options}->{$key};
    }
  }

  bless $self, $class;
}

sub pop {
  my ($self, $count) = @_;
  $count = 1 if !defined $count;
  $count = length($self->{string}) if $count > length($self->{string});

  my $popped = substr($self->{string}, 0, $count);
  substr($self->{string}, 0, $count) = '';

  return $popped;
}

sub peek {
  my ($self, $count) = @_;
  $count = 1 if !defined $count;
  $count = length($self->{string}) if $count > length($self->{string});

  my $peeked = substr($self->{string}, 0, $count);

  return $peeked;
}

sub push {
  my ($self, $string) = @_;

  $self->{string} = $string . $self->{string};
}

sub temp : lvalue {
  shift->{temp};
}

sub flush {
  my ($self, $var) = @_;

  if ( $self->{options}->{debug} ) {
    print STDERR "Flushing: $self->{temp}\n";
  }

  if ( $var ) {
    $$var .= $self->{temp};
  } else {
    $self->{output} .= $self->{temp};
  }
  $self->{temp} = '';
}

sub output : lvalue {
  shift->{output};
}

sub eval {
  my ($self, $string) = @_;

  $self->parse($string);
}

sub parse {
  my ($self, $string) = @_;
  return "" if !defined($string) || length($string) == 0;
  $self->output = '';
  $self->temp = '';
  $self->{func_depth} = 0;
  $self->{brace_depth} = 0;
  $self->{string} = $string;

  my $current = '';
  my $previous = '';

  OUTER: while (1) {
    $current = $self->pop;
    last if (!defined $current || length($current) == 0);

    SWITCH: {
      if ( defined(my $parse = $self->parse_character($current, $previous)) ) {
        $self->temp .= $parse;
        if ( $parse =~ /\s/o ) {
          $self->flush;
        }
        last SWITCH;
      }

      if ( $current eq '[' ) {
        $self->flush;
        $self->temp .= $self->parse_function;
        if ( $self->peek eq ']' ) {
          $self->pop;
        }
        last SWITCH;
      }

      if ( $current eq '(' && $self->output eq '' ) {
        $self->push($self->temp . '(');
        $self->temp = '';
        $self->temp = $self->parse_function;
        $self->flush;
        last SWITCH;
      }

      $self->temp .= $current;
    }

    $previous = $current;
  }
  $self->flush;

  return $self->output;
}

sub parse_variable {
  my ($self, $char) = @_;

  if ( defined(my $variable = $self->{variables}->{$char}) ) {
    if ( ref($variable) eq 'CODE' ) {
      return $variable->($char, $self);
    } elsif ( ref($variable) eq 'ARRAY' ) {
      return $variable->[$char];
    } elsif ( ref($variable) eq 'HASH' ) {
      return $variable->{$char};
    } elsif ( ref($variable) eq 'SCALAR' ) {
      return $$variable;
    } elsif ( ref($variable) && UNIVERSAL::can($variable, "eval") ) {
      return $variable->eval($char, $self);
    } else {
      return $variable;
    }
  }

  return $char;
}

sub parse_character {
  my ($self, $char, $prev) = @_;

  if ( $self->{options}->{space_compression}
  &&   ($prev =~ /\s/o
  ||    ($self->{func_depth} && $prev eq ',')) ) {
    return '' if ( $char =~ /\s/o );
  }

  if ( $prev eq '\\' ) {
# The previous character was a literal \, so we take the current character
# with no parsing.
    return $char;
  }

  if ( $prev eq '%' ) {
    return $self->parse_variable($char);
  }

  if ( $self->{brace_depth} && $char eq '}' ) {
    $self->{brace_depth}--;
    return '';
  }

  if ( $self->{brace_depth} || $char =~ /\s/o ) {
    return $char;
  }

  if ( $char eq '{' ) {
    $self->{brace_depth}++;
    return '';
  }

  if ( $char eq '%' ) {
    return '';
  }

  if ( $char eq '\\' ) {
    return '';
  }

  return;
}

sub parse_function {
  my ($self) = @_;

  my $current = "";
  my $previous = "";
  my @funcargs = ( );
  my $argc = 0;
  my $output = undef;

  $self->{func_depth}++;
  if ( $self->{options}->{debug} ) {
    print STDERR "Function call: depth: $self->{func_depth}\n";
    print STDERR "Function call: stack: $self->{string}\n";
  }

  OUTER: while ( 1 ) {
# Get the next character from the workspace and study it for regex
# testing.
    $current = $self->pop;
    last if (!defined $current || length($current) == 0);
    study $current;

    $output = \$funcargs[$argc];
    $$output = '' if ( !defined $$output );
    SWITCH: {
      if ( defined(my $parse = $self->parse_character($current, $previous)) ) {
        $self->temp .= $parse;
        last SWITCH;
      }

      if ( $current eq '(' ) {
# If we're currently changing the function name ($argc == 0), then this
# marks the end of the name and the beginning of the function arguments.
# So, we simply set $argc = 0 and move on.
        if ( $argc == 0 ) {
          $self->flush($output);
          $argc++;
          last SWITCH;
        }

# ( marks a function call.  We check to see if OUTPUT is empty.  If it is,
# then this is the first word of the statement and is passed as a function
# call.  If it isn't, then we just print a ( and move on.
        if ( $$output ne "" ) {
          $self->temp .= $current;
        } else {
          $self->push($self->temp . "(");
          $self->temp = '';
          $$output .= $self->parse_function;
        }
        last SWITCH;
      }

      if ( $current eq ',' ) {
        if ( $argc == 0 ) {
          $self->temp .= $current;
          last SWITCH;
        }

        $self->flush($output);
        $argc++;
        last SWITCH;
      }

      if ( $current eq ')' || $current eq ']' ) {
# Things get sexy here.  ) marks the end of the function call.  But ] does
# as well.  So, how do we handle )] or )blah]?  Easy!
# First, send output to OUTPUT.  This will REALLY hose your stack if you
# do )blah].  I want that (consider it a feature).
        $self->flush($output);
        last OUTER;
      }

      if ( $current eq '[' ) {
        $self->flush;
        $self->temp .= $self->parse_function;
        if ( $self->peek eq ']' ) {
          $self->pop;
        }
        last SWITCH;
      }

# Default case
      $self->temp .= $current;
    }

    $previous = $current;
  }

  if ( $self->{options}->{debug} ) {
    print STDERR "Function return: depth: $self->{func_depth}\n";
  }

  $self->{func_depth}--;

  my $func_info;
  my $func_name = lc shift @funcargs;
  if ( !defined($func_info = $self->{functions}->{$func_name}) ) {
    return "#-1 FUNCTION (\U$func_name\E) NOT FOUND";
  }

# Clean out empty arguments
  while ( $argc && $funcargs[$argc - 1] eq '' ) {
    CORE::pop @funcargs;
    $argc--;
  }

  my $min_arg = FN_VARARG;
  my $max_arg = FN_VARARG;
  if ( ref($func_info->[ARG_COUNT]) eq 'ARRAY' ) {
    ($min_arg, $max_arg) = @{ $func_info->[ARG_COUNT] };
  } else {
    $min_arg = $max_arg = $func_info->[ARG_COUNT];
  }

  if ( $func_info->[ARG_COUNT] != FN_VARARG
  &&   ($min_arg > $argc || $max_arg < $argc) ) {
    my $error = "#-1 FUNCTION (\U$func_name\E) EXPECTS ";
    if ( $min_arg == $max_arg ) {
      $error .= "$min_arg ARGUMENT" . ($min_arg == 1 ? "" : "S");
    } else {
      $error .= "BETWEEN $min_arg AND $max_arg ARGUMENTS";
    }
    $error .= ", GOT $argc";

    return $error;
  }

  my $flags = $func_info->[FNC_FLAGS] || 0;
  if ( $flags & FNC_PASS_NAME ) {
    unshift @funcargs, $func_name;
  }
  my $retval = $func_info->[CODE_REF]->(@funcargs);
  if ( $self->{options}->{debug} ) {
    print STDERR "Function return: value: $retval\n";
  }

  return $retval;
}

# Preloaded methods go here.

1;
__END__