File Coverage

blib/lib/Config/INI/RefVars/Builtins.pm

Criterion	Covered	Total	%
statement	82	83	98.8
branch	46	62	74.1
condition	17	25	68.0
subroutine	23	23	100.0
pod	1	1	100.0
total	169	194	87.1

# lib/Config/INI/RefVars/Builtins.pm
package Config::INI::RefVars::Builtins;

use 5.010;
use strict;
use warnings;

use File::Spec::Functions qw(catdir catfile);
use File::Basename qw(dirname basename);


our $VERSION = '1.02';


sub default_dispatch_table {
  return {
          catdir   => \&catdir,
          catfile  => \&catfile,
          ignore   => \&_ignore,
          concat   => \&_concat,
          join     => \&_join,
          substr   => \&_substr,
          x        => \&_x,
          'and'    => \&_and,
          'or'     => \&_or,
          'if'     => \&_if,
          s        => \&_s,
          tr       => \&_tr,
          m        => \&_m,
          not      => \&_not,
          eq       => \&_eq,
          dirname  => \&dirname,
          basename => \&basename,
         };
}


sub _clean_error {
  my ($error) = @_;
  chomp($error);
  $error =~ s/\s+at\s+\S+\s+line\s+\d+\.?\z//;
  return $error;
}


sub _ignore {
  return "";
}


sub _concat {
  return join("", @_);
}


sub _join {
  return @_ ? join(shift(@_), @_) : "";
}


sub _substr {
  die("substr: expected 2 or 3 arguments\n") if @_ < 2 || @_ > 3;

  my $warning = "";

  local $SIG{__WARN__} = sub {
    $warning = _clean_error($_[0]);
  };

  my $result = @_ == 2
    ? substr($_[0], $_[1]) : substr($_[0], $_[1], $_[2]);

  die("substr: $warning\n") if $warning ne "";
  return $result;
}


sub _x {
  die("x: expected 2 arguments\n") if @_ != 2;

  my ($str, $n) = @_;

  die("x: second argument must be a non-negative integer\n")
    unless $n =~ /^\+?[0-9]+$/;

  return $str x $n;
}


sub _and {
  foreach my $arg (@_) {
    return "" if $arg eq "";
  }
  return @_ ? $_[-1] : "";
}


sub _or {
  foreach my $arg (@_) {
    return $arg if $arg ne "";
  }
  return "";
}


sub _if {
  die("if: expected 2 or 3 arguments\n") if @_ < 2 || @_ > 3;
  return $_[0] ne "" ? $_[1] : ($_[2] // "");
}


sub _s {
  die("s: expected 3 or 4 arguments\n") if @_ < 3 || @_ > 4;

  my ($str, $pattern, $replacement, $mods) = @_;
  $mods //= "";

  die("s: unsupported modifier '$mods'\n") if $mods !~ /^[gimsx]*$/;

  die("s: regex code blocks are not allowed\n") if $pattern =~ /\(\?\??\{/;

  my $global = $mods =~ s/g//g;
  my $re = eval { $mods eq "" ? qr/$pattern/ : qr/(?$mods:$pattern)/; };
  die("s: ", _clean_error($@), "\n") if $@;

  if ($global) {
    $str =~ s/$re/$replacement/g;
  }
  else {
    $str =~ s/$re/$replacement/;
  }
  return $str;
}


sub _pick_tr_delim {
  my @values = @_;

  no warnings 'qw';
  foreach my $delim (qw(| ! / : ; # ~ @ % ^ * + = ?)) {
    return $delim if !grep { index($_ // "", $delim) >= 0 } @values;
  }
  die("tr: no safe delimiter found\n");
}


sub _tr {
  die("tr: expected 3 or 4 arguments\n") if @_ < 3 || @_ > 4;

  my ($str, $search, $replacement, $mods) = @_;
  $mods //= "";

  die("tr: unsupported modifier '$mods'\n") if $mods !~ /^[cds]*$/;

  my $delim = _pick_tr_delim($search, $replacement);
  my $code = "\$str =~ tr${delim}${search}${delim}${replacement}${delim}${mods};";
  eval "$code; 1" or die("tr: ", _clean_error($@), "\n");

  return $str;
}


sub _m {
  die("m: expected 2 or 3 arguments\n") if @_ < 2 || @_ > 3;

  my ($str, $pattern, $mods) = @_;
  $mods //= "";

  die("m: unsupported modifier '$mods'\n") if $mods !~ /^[imsx]*$/;
  die("m: regex code blocks are not allowed\n") if $pattern =~ /\(\?\??\{/;

  my $re = eval { $mods eq "" ? qr/$pattern/ : qr/(?$mods:$pattern)/; };
  die("m: ", _clean_error($@), "\n") if $@;

  return $str =~ $re ? "1" : "";
}


sub _not {
  die("not: expected 1 argument\n") if @_ != 1;
  return $_[0] eq "" ? "1" : "";
}


sub _eq {
  die("eq: expected 2 arguments\n") if @_ != 2;
  return $_[0] eq $_[1] ? "1" : "";
}

1;


__END__