libcgi-cookie-xs-perl/inc/Test/Base/Filter.pm

#line 1
#. TODO:
#.

#===============================================================================
# This is the default class for handling Test::Base data filtering.
#===============================================================================
package Test::Base::Filter;
use Spiffy -Base;
use Spiffy ':XXX';

field 'current_block';

our $arguments;
sub current_arguments {
    return undef unless defined $arguments;
    my $args = $arguments;
    $args =~ s/(\\s)/ /g;
    $args =~ s/(\\[a-z])/'"' . $1 . '"'/gee;
    return $args;
}

sub assert_scalar {
    return if @_ == 1;
    require Carp;
    my $filter = (caller(1))[3];
    $filter =~ s/.*:://;
    Carp::croak "Input to the '$filter' filter must be a scalar, not a list";
}

sub _apply_deepest {
    my $method = shift;
    return () unless @_;
    if (ref $_[0] eq 'ARRAY') {
        for my $aref (@_) {
            @$aref = $self->_apply_deepest($method, @$aref);
        }
        return @_;
    }
    $self->$method(@_);
}

sub _split_array {
    map {
        [$self->split($_)];
    } @_;
}

sub _peel_deepest {
    return () unless @_;
    if (ref $_[0] eq 'ARRAY') {
        if (ref $_[0]->[0] eq 'ARRAY') {
            for my $aref (@_) {
                @$aref = $self->_peel_deepest(@$aref);
            }
            return @_;
        }
        return map { $_->[0] } @_;
    }
    return @_;
}

#===============================================================================
# these filters work on the leaves of nested arrays
#===============================================================================
sub Join { $self->_peel_deepest($self->_apply_deepest(join => @_)) }
sub Reverse { $self->_apply_deepest(reverse => @_) }
sub Split { $self->_apply_deepest(_split_array => @_) }
sub Sort { $self->_apply_deepest(sort => @_) }


sub append {
    my $suffix = $self->current_arguments;
    map { $_ . $suffix } @_;
}

sub array {
    return [@_];
}

sub base64_decode {
    $self->assert_scalar(@_);
    require MIME::Base64;
    MIME::Base64::decode_base64(shift);
}

sub base64_encode {
    $self->assert_scalar(@_);
    require MIME::Base64;
    MIME::Base64::encode_base64(shift);
}

sub chomp {
    map { CORE::chomp; $_ } @_;
}

sub chop {
    map { CORE::chop; $_ } @_;
}

sub dumper {
    no warnings 'once';
    require Data::Dumper;
    local $Data::Dumper::Sortkeys = 1;
    local $Data::Dumper::Indent = 1;
    local $Data::Dumper::Terse = 1;
    Data::Dumper::Dumper(@_);
}

sub escape {
    $self->assert_scalar(@_);
    my $text = shift;
    $text =~ s/(\\.)/eval "qq{$1}"/ge;
    return $text;
}

sub eval {
    $self->assert_scalar(@_);
    my @return = CORE::eval(shift);
    return $@ if $@;
    return @return;
}

sub eval_all {
    $self->assert_scalar(@_);
    my $out = '';
    my $err = '';
    Test::Base::tie_output(*STDOUT, $out);
    Test::Base::tie_output(*STDERR, $err);
    my $return = CORE::eval(shift);
    no warnings;
    untie *STDOUT;
    untie *STDERR;
    return $return, $@, $out, $err;
}

sub eval_stderr {
    $self->assert_scalar(@_);
    my $output = '';
    Test::Base::tie_output(*STDERR, $output);
    CORE::eval(shift);
    no warnings;
    untie *STDERR;
    return $output;
}

sub eval_stdout {
    $self->assert_scalar(@_);
    my $output = '';
    Test::Base::tie_output(*STDOUT, $output);
    CORE::eval(shift);
    no warnings;
    untie *STDOUT;
    return $output;
}

sub exec_perl_stdout {
    my $tmpfile = "/tmp/test-blocks-$$";
    $self->_write_to($tmpfile, @_);
    open my $execution, "$^X $tmpfile 2>&1 |"
      or die "Couldn't open subprocess: $!\n";
    local $/;
    my $output = <$execution>;
    close $execution;
    unlink($tmpfile)
      or die "Couldn't unlink $tmpfile: $!\n";
    return $output;
}

sub flatten {
    $self->assert_scalar(@_);
    my $ref = shift;
    if (ref($ref) eq 'HASH') {
        return map {
            ($_, $ref->{$_});
        } sort keys %$ref;
    }
    if (ref($ref) eq 'ARRAY') {
        return @$ref;
    }
    die "Can only flatten a hash or array ref";
}

sub get_url {
    $self->assert_scalar(@_);
    my $url = shift;
    CORE::chomp($url);
    require LWP::Simple;
    LWP::Simple::get($url);
}

sub hash {
    return +{ @_ };
}

sub head {
    my $size = $self->current_arguments || 1;
    return splice(@_, 0, $size);
}

sub join {
    my $string = $self->current_arguments;
    $string = '' unless defined $string;
    CORE::join $string, @_;
}

sub lines {
    $self->assert_scalar(@_);
    my $text = shift;
    return () unless length $text;
    my @lines = ($text =~ /^(.*\n?)/gm);
    return @lines;
}

sub norm {
    $self->assert_scalar(@_);
    my $text = shift;
    $text = '' unless defined $text;
    $text =~ s/\015\012/\n/g;
    $text =~ s/\r/\n/g;
    return $text;
}

sub prepend {
    my $prefix = $self->current_arguments;
    map { $prefix . $_ } @_;
}

sub read_file {
    $self->assert_scalar(@_);
    my $file = shift;
    CORE::chomp $file;
    open my $fh, $file
      or die "Can't open '$file' for input:\n$!";
    CORE::join '', <$fh>;
}

sub regexp {
    $self->assert_scalar(@_);
    my $text = shift;
    my $flags = $self->current_arguments;
    if ($text =~ /\n.*?\n/s) {
        $flags = 'xism'
          unless defined $flags;
    }
    else {
        CORE::chomp($text);
    }
    $flags ||= '';
    my $regexp = eval "qr{$text}$flags";
    die $@ if $@;
    return $regexp;
}

sub reverse {
    CORE::reverse(@_);
}

sub slice {
    die "Invalid args for slice"
      unless $self->current_arguments =~ /^(\d+)(?:,(\d))?$/;
    my ($x, $y) = ($1, $2);
    $y = $x if not defined $y;
    die "Invalid args for slice"
      if $x > $y;
    return splice(@_, $x, 1 + $y - $x);
}

sub sort {
    CORE::sort(@_);
}

sub split {
    $self->assert_scalar(@_);
    my $separator = $self->current_arguments;
    if (defined $separator and $separator =~ s{^/(.*)/$}{$1}) {
        my $regexp = $1;
        $separator = qr{$regexp};
    }
    $separator = qr/\s+/ unless $separator;
    CORE::split $separator, shift;
}

sub strict {
    $self->assert_scalar(@_);
    <<'...' . shift;
use strict;
use warnings;
...
}

sub tail {
    my $size = $self->current_arguments || 1;
    return splice(@_, @_ - $size, $size);
}

sub trim {
    map {
        s/\A([ \t]*\n)+//;
        s/(?<=\n)\s*\z//g;
        $_;
    } @_;
}

sub unchomp {
    map { $_ . "\n" } @_;
}

sub write_file {
    my $file = $self->current_arguments
      or die "No file specified for write_file filter";
    if ($file =~ /(.*)[\\\/]/) {
        my $dir = $1;
        if (not -e $dir) {
            require File::Path;
            File::Path::mkpath($dir)
              or die "Can't create $dir";
        }
    }
    open my $fh, ">$file"
      or die "Can't open '$file' for output\n:$!";
    print $fh @_;
    close $fh;
    return $file;
}

sub yaml {
    $self->assert_scalar(@_);
    require YAML;
    return YAML::Load(shift);
}

sub _write_to {
    my $filename = shift;
    open my $script, ">$filename"
      or die "Couldn't open $filename: $!\n";
    print $script @_;
    close $script
      or die "Couldn't close $filename: $!\n";
}

__DATA__

#line 639