File Coverage

blib/lib/Spp/Builtin.pm

Criterion	Covered	Total	%
statement	117	225	52.0
branch	19	64	29.6
condition			n/a
subroutine	39	65	60.0
pod	0	53	0.0
total	175	407	43.0

package Spp::Builtin;

use 5.012;
no warnings "experimental";

use Exporter;
our @ISA    = qw(Exporter);
our @EXPORT = qw(End In Out True False Qstr Qint Blank
  clean first string strings sort_array to_json from_json
  is_exists first_char last_char rest_str tail rest
  is_string is_int is_array Chop add uuid
  error read_file write_file len trim subarray
  is_space is_upper is_lower is_digit is_xdigit
  is_alpha is_words is_hspace is_vspace
  start_with end_with to_end get_time change_sufix
  get_file_mtime is_update tidy_perl find_wanted
  to_int copy is_false is_true croak
  estr estr_ints is_str is_bool is_estr is_blank
  cons cons_atom);

use File::Find::Wanted qw(find_wanted);
use Time::Piece;
use File::Basename qw(fileparse);
use Perl::Tidy;
use File::Copy qw(copy);
use String::Random;
use JSON::XS qw(decode_json encode_json);
use Carp;

use constant {
  End   => chr(0),
  In    => chr(1),
  Out   => chr(2),
  True  => chr(3),
  False => chr(4),
  Qstr  => chr(5),
  Qint  => chr(6),
  Blank => (chr(1) . chr(2)),
};

sub cons {
  my @args = @_;
  my $estr = join '', map { cons_atom($_) } @args;
  return (In . $estr . Out);
}

sub cons_atom {
  my $atom = shift;
  if (is_estr($atom)) { return $atom }
  if (is_int($atom))  { return (Qint . $atom) }
  if ($atom eq '')    { error("cons blank Str") }
  if (is_str($atom))  { return (Qstr . $atom) }
  croak("not estr or str or int??");
}

sub estr {
  my $estr_array = shift;
  if (is_string($estr_array)) { croak('trace it...') }
  return cons(@{$estr_array});
}

sub estr_ints {
  my $ints = shift;
  my @estrs = map { (Qint . $_) } @{$ints};
  return In . join('', @estrs) . Out;
}

sub is_str {
  my $str = shift;
  if (is_string($str)) {
    my $char = substr($str, 0, 1);
    if (ord($char) > 6) { return 1 }
  }
  return 0;
}

sub is_bool {
  my $char = shift;
  if (is_false($char)) { return 1 }
  if (is_true($char))  { return 1 }
  return 0;
}

sub is_estr {
  my $str = shift;
  return substr($str, 0, 1) eq In;
}

sub is_blank {
  my $estr = shift;
  return $estr eq Blank;
}

sub error { say @_; exit() }

sub to_json {
  my $data = shift;
  return encode_json($data);
}

sub from_json {
  my $data = shift;
  return decode_json($data);
}

sub clean {
  my $stack = shift;
  @{$stack} = ();
}

sub string {
  my $stack = shift;
  return join '', @{$stack};
}

sub first {
  my $stack = shift;
  if (is_array($stack)) {
    return $stack->[0];
  }
  croak("Could not first not Array");
  return False
}

sub strings {
  my $stack = shift;
  return $stack;
}

sub sort_array {
  my $array = shift;
  return [reverse sort @{$array}];
}

sub uuid {
  my $gen = String::Random->new;
  return $gen->randregex('[A-Z]{5}');
}

sub is_exists {
  my $file = shift;
  return (-e $file);
}

sub first_char {
  my $data = shift;
  if (is_string($data)) {
    return substr $data, 0, 1;
  }
  croak("could not first No Str");
  return True
}

sub last_char {
  my $str = shift;
  if (is_string($str)) {
    return substr $str, -1;
  }
  croak("Could not last-char Array");
}

sub rest_str {
  my $data = shift;
  return substr($data, 1) if is_string($data);
  croak("rest_str only could do str");
}

sub tail {
  my $data = shift;
  if (is_array($data)) {
    return $data->[-1];
  }
  croak("Could not tail not Array");
}

sub rest {
  my $data = shift;
  if (is_array($data)) {
    my @array = @{$data};
    return [splice(@array, 1)];
  }
  croak("rest only could do array");
}

sub is_string {
  my $x = shift;
  return (ref($x) eq ref(''));
}

sub is_int {
  my $int = shift;
  return ($int ^ $int) eq '0';
}

sub is_array {
  my $x = shift;
  return (ref($x) eq ref([]));
}

sub Chop {
  my $str = shift;
  return substr($str, 0, -1);
}

sub add {
  my @strs = @_;
  return join '', @strs;
}

sub read_file {
  my $file = shift;
  error("file: $file not exists") if not(-e $file);
  local $/;
  open my ($fh), '<:encoding(UTF-8)', $file or die $!;
  return <$fh>;
}

sub write_file {
  my ($file, $str) = @_;
  open my ($fh), '>:encoding(UTF-8)', $file or die $!;
  print {$fh} $str;
  # say "write file: $file ok!";
  return $file;
}

sub len {
  my $data = shift;
  return length($data) if is_string($data);
  return scalar(@{$data}) if is_array($data);
  croak("len only make array");
}

sub trim {
  my $str = shift;
  if (is_string($str)) {
    $str =~ s/^\s+|\s+$//g;
    return $str;
  }
  croak("trim only make string");
}

sub subarray {
  my ($array, $from, $to) = @_;
  my @array = @{$array};
  if (is_array($array)) {
    if ($to > 0) {
      my $len = $to - $from + 1;
      my $sub_array = [splice @array, $from, $len];
      return $sub_array;
    }
    if (defined $to) {
      return [splice @array, $from, $to];
    }
    return [splice @array, $from];
  }
  croak("subarray only could process array");
}

sub is_space {
  my $r = shift;
  return $r ~~ ["\n", "\t", "\r", ' '];
}

sub is_upper {
  my $r = shift;
  return $r ~~ ['A' .. 'Z'];
}

sub is_lower {
  my $r = shift;
  return $r ~~ ['a' .. 'z'];
}

sub is_digit {
  my $r = shift;
  return $r ~~ ['0' .. '9'];
}

sub is_xdigit {
  my $char = shift;
  return 1 if is_digit($char);
  return 1 if $char ~~ ['a' .. 'f'];
  return 1 if $char ~~ ['A' .. 'F'];
  return 0;
}

sub is_alpha {
  my $r = shift;
  return $r ~~ ['a' .. 'z', 'A' .. 'Z', '_'];
}

sub is_words {
  my $r = shift;
  return 1 if is_digit($r);
  return 1 if is_alpha($r);
  return 0;
}

sub is_hspace {
  my $h = shift;
  return $h ~~ [' ', "\t"];
}

sub is_vspace {
  my $v = shift;
  return $v ~~ ["\r", "\n"];
}

sub start_with {
  my ($str, $start) = @_;
  return 1 if index($str, $start) == 0;
  return 0;
}

sub end_with {
  my ($str, $end) = @_;
  my $len = length($end);
  return substr($str, -$len) eq $end;
}

sub to_end {
  my $str = shift;
  my $index = index($str, "\n");
  return substr($str, 0, $index);
}

sub get_time {
  my $t = localtime;
  return $t->hms('-');
}

sub change_sufix {
  my ($file, $from_sufix, $to_sufix) = @_;
  my @sufix = ($from_sufix);
  my ($name, $path) = fileparse($file, @sufix);
  return $path . $name . $to_sufix;
}

sub get_file_mtime {
  my $file = shift;
  if (not(-e $file)) {
    say "$file is not exists!";
  }
  else {
    return (stat($file))[9];
  }
}

sub is_update {
  my ($file, $to_file) = @_;
  my $file_mtime    = get_file_mtime($file);
  my $to_file_mtime = get_file_mtime($to_file);
  return ($file_mtime < $to_file_mtime);
}

sub to_int {
  my $str = shift;
  return 0 + $str;
}

sub is_false {
  my $char = shift;
  return $char eq False;
}

sub is_true {
  my $char = shift;
  return $char eq True;
}

sub tidy_perl {
  my $source_string = shift;
  my $dest_string;
  my $stderr_string;
  my $errorfile_string;
  my $argv  = "-i=2 -l=60 -vt=2 -pt=2 -bt=1 -sbt=2 -bbt=1";
  my $error = Perl::Tidy::perltidy(
    argv        => $argv,
    source      => \$source_string,
    destination => \$dest_string,
    stderr      => \$stderr_string,
    errorfile   => \$errorfile_string,
  );

  if ($error) {
    print "<<STDERR>>\n$stderr_string\n";
  }
  return $dest_string;
}

1;