view release on metacpan or  search on metacpan

lib/Params/PatternMatch.pm  view on Meta::CPAN

package Params::PatternMatch;

# ABSTRACT: Pattern match-based argument binding for Perl.

use strict;
use warnings;
use B;
use Carp;
use Data::Compare;
use Exporter::Lite;
use Scalar::Util qw/blessed/;
use TryCatch;

our $COMPARATOR = Data::Compare->new;

our @EXPORT_OK = qw/as case match otherwise rest then/;

our $VERSION = '0.01';

our @args;

sub as(&) { @_ }

sub case {
  my $action = pop;
  Carp::croak('Not a CodeRef.') if ref $action ne 'CODE';

  my ($i, $j) = (0, 0);
  for (; $i < @args and $j < @_; ++$i, ++$j) {
    if (is_slurp_arg($_[$j])) {
      $_[$j]->set(@args[$i .. $#args]);
      $i = $#args;
      next;
    }
    if (is_lvalue($_[$j])) {
      $_[$j] = $args[$i];
      next;
    }
    next if $COMPARATOR->Cmp($args[$i], $_[$j]) != 0;

    return;  # Pattern didn't match.
  }
  return unless $i == @args and $j == @_ or is_slurp_arg($_[$j]);

  die Params::PatternMatch::Values->new($action->(@args));
}

sub is_lvalue($) { +(B::svref_2object(\$_[0])->FLAGS & B::SVf_READONLY) == 0 }

sub is_slurp_arg($) {
  blessed $_[0] and $_[0]->isa('Params::PatternMatch::SlurpArg');
}

sub match {
  my $patterns = pop;
  Carp::croak('Not a CodeRef.') if ref $patterns ne 'CODE';

  local *args = \@_;
  try {
    $patterns->();
  } catch (Params::PatternMatch::Values $retval) {
    return $retval->values;
  } catch ($error) {
    die $error;
  };
}

sub otherwise(&) {
  Carp::croak('Not a CodeRef.') if ref $_[0] ne 'CODE';
  die Params::PatternMatch::Values->new($_[0]->(@args));
}

sub rest(\@) { Params::PatternMatch::SlurpArg->new($_[0]) }

sub then(&) { @_ }

package Params::PatternMatch::SlurpArg;

sub new { bless $_[1] => $_[0] }

sub set { @{ $_[0] } = @_[1 .. $#_ ] }