File Coverage

blib/lib/Blatte/Builtins.pm

Criterion	Covered	Total	%
statement	13	13	100.0
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	18	100.0

package Blatte::Builtins;

use strict;

BEGIN {
  @Blatte::Builtins::builtins = qw($acall $add $ameth $append $apply
                                   $aref $aset $concat $defined
                                   $divide $streq $flatten $foreach
                                   $funcall $numge $numgt $hashdel $hashkeys
                                   $hashp $hashref $hashset $hashtest
                                   $int $lc $lcfirst $numle $length $list
                                   $listp $numlt $match $max $min $mkhash
                                   $multiply $not $numeq $pop $push
                                   $random $require $use $scall $shift
                                   $smeth $split $sprintf $strge
                                   $strgt $strle $strlt $subseq $subst
                                   $substr $subtract $uc $ucfirst
                                   $unshift);
}

use vars (qw(@ISA @EXPORT), @Blatte::Builtins::builtins);

use Exporter;

@ISA = qw(Exporter);

@EXPORT = @Blatte::Builtins::builtins;

use Blatte qw(traverse true unwrapws flatten);

## Data types

$foreach = sub {
  my $fn = &unwrapws($_[1]);
  my @result = map { &$fn({}, &unwrapws($_)) } @{&unwrapws($_[2])};
  \@result;
};

$length = sub {
  my $obj = &unwrapws($_[1]);
  if (ref($obj) eq 'ARRAY') {   # xxx UNIVERSAL::isa ?
    return scalar(@$obj);
  }
  length($obj);
};

$listp = sub {
  ref(&unwrapws($_[1])) eq 'ARRAY'; # xxx UNIVERSAL::isa ?
};

$list = sub {
  if (@_ > 1) {
    [&unwrapws($_[1]), @_[2..$#_]];
  } else {
    [];
  }
};

$subseq = sub {
  my($list, $start) = (&unwrapws($_[1]), &unwrapws($_[2]));
  if ($start < 0) {
    $start += @$list;
  }
  my $len;
  if (@_ > 3) {
    $len = &unwrapws($_[3]);
  } else {
    $len = @$list - $start;
  }
  [@$list[$start .. $start + $len]];
};

$not = sub {
  !&true(&unwrapws($_[1]));
};

$defined = sub {
  defined(&unwrapws($_[1]));
};

## Array references

$aref = sub {
  &unwrapws($_[1])->[&unwrapws($_[2])];
};

$aset = sub {
  &unwrapws($_[1])->[&unwrapws($_[2])] = $_[3];
};

$push = sub {
  my $list = &unwrapws($_[1]);
  push(@$list, @_[2..$#_]);
  $list;
};

$pop = sub {
  pop(@{&unwrapws($_[1])});
};

$unshift = sub {
  my $list = &unwrapws($_[1]);
  unshift(@$list, @_[2..$#_]);
  $list;
};

$shift = sub {
  shift(@{&unwrapws($_[1])});
};

$append = sub {
  my $result = [];
  foreach my $l (@_[1..$#_]) {
    push(@$result, @$l);
  }
  $result;
};

## Hash references

$hashp = sub {
  ref(&unwrapws($_[1])) eq 'HASH'; # xxx UNIVERSAL::isa ?
};

$mkhash = sub {
  my $result = {};
  for (my $i = 1; $i <= $#_; $i += 2) {
    $result->{&unwrapws($_[$i])} = $_[$i + 1];
  }
  $result;
};

$hashref = sub {
  &unwrapws($_[1])->{&unwrapws($_[2])};
};

$hashset = sub {
  &unwrapws($_[1])->{&unwrapws($_[2])} = $_[3];
};

$hashdel = sub {
  delete &unwrapws($_[1])->{&unwrapws($_[2])};
};

$hashtest = sub {
  exists &unwrapws($_[1])->{&unwrapws($_[2])};
};

$hashkeys = sub {
  my @result = keys %{&unwrapws($_[1])};
  \@result;
};

## Perl function-calling interface

$acall = sub {
  my $name = &unwrapws($_[1]);
  my @result = &$name(@_[2..$#_]);
  \@result;
};

$scall = sub {
  my $name = &unwrapws($_[1]);
  scalar(&$name(@_[2..$#_]));
};

## Perl object interface

$ameth = sub {
  my $obj = &unwrapws($_[1]);
  my $meth = &unwrapws($_[2]);
  my @result = $obj->$meth(@_[3..$#_]);
  \@result;
};

$smeth = sub {
  my $obj = &unwrapws($_[1]);
  my $meth = &unwrapws($_[2]);
  scalar($obj->$meth(@_[3..$#_]));
};

## Arithmetic

$add = sub {
  my $result = 0;
  foreach my $num (@_[1..$#_]) {
    $result += &unwrapws($num);
  }
  $result;
};

$multiply = sub {
  my $result = 1;
  foreach my $num (@_[1..$#_]) {
    $result *= &unwrapws($num);
  }
  $result;
};

$subtract = sub {
  my $result = &unwrapws($_[1]);
  if (@_ > 2) {
    foreach my $num (@_[2..$#_]) {
      $result -= &unwrapws($num);
    }
  } else {
    $result = -$result;
  }
  $result;
};

$divide = sub {
  my $result = &unwrapws($_[1]);
  if (@_ > 2) {
    foreach my $num (@_[2..$#_]) {
      $result /= &unwrapws($num);
    }
  } else {
    $result = 1.0 / $result;
  }
  $result;
};

## Lisp-like primitives

$funcall = sub {
  my $sub = &unwrapws($_[1]);
  &$sub($_[0], @_[2..$#_]);
};

$apply = sub {
  my $sub = &unwrapws($_[1]);
  my @args = @_[2 .. ($#_ - 1)];
  if (@_ > 2) {
    my $last = $_[$#_];
    my $last_unwrapped = &unwrapws($last);
    if (ref($last_unwrapped) eq 'ARRAY') { # xxx UNIVERSAL::isa ?
      push(@args, @$last_unwrapped);
    } else {
      push(@args, $last);
    }
  }
  &$sub($_[0], @args);
};

## Strings

$flatten = sub {
  my $result = '';

  foreach my $obj (@_[1..$#_]) {
    $result .= &flatten($obj);
  }

  $result;
};

$uc = sub {
  uc(&unwrapws($_[1]));
};

$lc = sub {
  lc(&unwrapws($_[1]));
};

$ucfirst = sub {
  ucfirst(&unwrapws($_[1]));
};

$lcfirst = sub {
  lcfirst(&unwrapws($_[1]));
};

$concat = sub {
  my $result;
  foreach my $str (@_[1..$#_]) {
    $result .= &unwrapws($str);
  }
  $result;
};

$substr = sub {
  my $str = &unwrapws($_[1]);
  my $start = &unwrapws($_[2]);
  if ($#_ == 2) {
    return substr($str, $start);
  }
  my $len = &unwrapws($_[3]);
  if ($#_ == 3) {
    return substr($str, $start, $len);
  }
  substr($str, $start, $len, &unwrapws($_[4]));
};

$sprintf = sub {
  my $fmt = &unwrapws($_[1]);
  sprintf($fmt, map { &unwrapws($_) } @_[2 .. $#_]);
};

$streq = sub {
  my $first = &unwrapws($_[1]);
  for (my $i = 2; $i <= $#_; ++$i) {
    if ($first ne &unwrapws($_[$i])) {
      return undef;
    }
  }
  1;
};

$strlt = sub {
  my $n = &unwrapws($_[1]);
  foreach my $m (@_[2..$#_]) {
    $m = &unwrapws($m);
    return undef unless $n lt $m;
    $n = $m;
  }
  1;
};

$strle = sub {
  my $n = &unwrapws($_[1]);
  foreach my $m (@_[2..$#_]) {
    $m = &unwrapws($m);
    return undef unless $n le $m;
    $n = $m;
  }
  1;
};

$strgt = sub {
  my $n = &unwrapws($_[1]);
  foreach my $m (@_[2..$#_]) {
    $m = &unwrapws($m);
    return undef unless $n gt $m;
    $n = $m;
  }
  1;
};

$strge = sub {
  my $n = &unwrapws($_[1]);
  foreach my $m (@_[2..$#_]) {
    $m = &unwrapws($m);
    return undef unless $n ge $m;
    $n = $m;
  }
  1;
};

## Numbers

$random = sub {
  if ($#_ == 0) {
    return rand(1);
  }
  rand(&unwrapws($_[1]));
};

$int = sub {
  int(&unwrapws($_[$#_]));
};

$numeq = sub {
  my $first = &unwrapws($_[1]);
  for (my $i = 2; $i <= $#_; ++$i) {
    if ($first != &unwrapws($_[$i])) {
      return undef;
    }
  }
  1;
};

$max = sub {
  my $result = &unwrapws($_[1]);
  for (my $i = 2; $i <= $#_; ++$i) {
    my $n = &unwrapws($_[$i]);
    $result = $n if $n > $result;
  }
  $result;
};

$min = sub {
  my $result = &unwrapws($_[1]);
  for (my $i = 2; $i <= $#_; ++$i) {
    my $n = &unwrapws($_[$i]);
    $result = $n if $n < $result;
  }
  $result;
};

$numlt = sub {
  my $n = &unwrapws($_[1]);
  foreach my $m (@_[2..$#_]) {
    $m = &unwrapws($m);
    return undef unless $n < $m;
    $n = $m;
  }
  1;
};

$numle = sub {
  my $n = &unwrapws($_[1]);
  foreach my $m (@_[2..$#_]) {
    $m = &unwrapws($m);
    return undef unless $n <= $m;
    $n = $m;
  }
  1;
};

$numgt = sub {
  my $n = &unwrapws($_[1]);
  foreach my $m (@_[2..$#_]) {
    $m = &unwrapws($m);
    return undef unless $n > $m;
    $n = $m;
  }
  1;
};

$numge = sub {
  my $n = &unwrapws($_[1]);
  foreach my $m (@_[2..$#_]) {
    $m = &unwrapws($m);
    return undef unless $n >= $m;
    $n = $m;
  }
  1;
};

## Perl modules

$require = sub {
  require &unwrapws($_[1]);
};

$use = sub {
  shift;
  eval sprintf('use %s', &flatten(\@_, ''));
};

## Regular expressions

$match = sub {
  my $flags = $_[0]->{flags};
  my $str = &unwrapws($_[1]);
  my $regex = &unwrapws($_[2]);
  my @result = eval("\$str =~ /\$regex/$flags");
  \@result;
};

$subst = sub {
  my $flags = $_[0]->{flags};
  my $str = &unwrapws($_[1]);
  my $regex = &unwrapws($_[2]);
  my $replacement = &unwrapws($_[3]);
  eval("\$str =~ s/\$regex/\$replacement/$flags");
  $str;
};

$split = sub {
  my $flags = $_[0]->{flags};
  my $str = &unwrapws($_[1]);
  my $regex = &unwrapws($_[2]);
  if ($#_ == 2) {
    my @result = eval("split(/\$regex/$flags, \$str)");
    return \@result;
  }
  my $limit = &unwrapws($_[3]);
  my @result = eval("split(/\$regex/$flags, \$str, \$limit)");
  \@result;
};

1;

__END__