App-pl
view release on metacpan or search on metacpan
$q, $quote,
$Q, $Quote,
$R, $RESULT,
@R, @RESULT,
%R, %RESULT,
$T, $TXT_SORT );
# Echo remove quine
sub echo(@) {
if( wantarray ) {
my @ret = &Echo;
$ret[-1] .= "\n" if @ret;
@ret;
} elsif( defined wantarray ) {
join( ' ', &Echo ) . "\n";
} else {
local $, = ' ';
say &Echo;
}
}
# Echo without newline
sub Echo(@) {
if( wantarray ) {
map {
if( ! defined ) {
"$pl::c{I}undef$pl::c{E}";
} elsif( !ref ) {
$_;
} elsif( eval { $_->can( '(""' ) } ) {
"$_";
} else {
require Data::Dumper;
} @_ ? @_ : $_;
} elsif( defined wantarray ) {
join ' ', &Echo;
} else {
local( $,, $\, $| ) = (' ', '', 1);
print &Echo;
}
}
# Would call it format, but that's not overridable.
sub form($@) {
echo &Form;
}
# Form without newline
sub Form($@) {
(my $form = shift) =~ s/%\K(%|[^a-z]+)/ my $x = $1; $x =~ tr!:!$!; $x /eg; # also matches %%, todo /r
Echo sprintf $form, &Echo;
}
sub benchmark(&@) {
my( $code, $name, @args ) = @_;
local( $a, $b ) = ($a, $b);
$name //= 'anonymous';
require Benchmark;
local $SIG{__WARN__} = sub { die @_ };
if( @args ) {
say Benchmark::timestr( Benchmark::countit( 10, $code )), " $name: $_"
for @args;
} else {
say Benchmark::timestr( Benchmark::countit( 10, $code )), " $name";
}
}
# Do it 100x for very fast test code (to increase weight compared to Benchmark overhead).
sub Benchmark(&@) {
my( $code, @rest ) = @_;
benchmark { for my $i (0..99) { &$code() }} @rest;
}
sub Config(@) {
require Config;
if( @_ ) {
#{map { pairgrep { $a =~ /$_/ } %Config::Config } @_}; # needs 5.20
my %config;
while( my( $k, $v ) = each %Config::Config ) {
$k =~ $_ and $config{$k} = $v, last
for @_;
}
\%config;
} else {
\%Config::Config;
}
}
sub Date(@) {
my( $s, $us, $tz, $tzo );
require Time::HiRes;
for( @_ ) {
if( ref ) {
($s, $us) = @$_;
} elsif( /^([-+]?)(1[0-4]|0?[0-9])(?:\.([0-9])([0-9])?|:([0-5])?([0-9]))?$/i ) {
$tz = $2 * 3600 + ($3 ? ($3.($4//0)) * 36 : $6 ? (($5//0).$6) * 60 : 0);
$tzo = sprintf ' %s%02d:%02d', $1 || '+', $tz / 3600, $tz % 3600 / 60;
$tz = -$tz if $1 eq '-';
} elsif( /^([-+]?)(?=.)([0-9]*)(?:\.([0-9]*))?$/i ) {
my @time = reverse +(defined( $tz ) ? gmtime $s + $tz : localtime $s)[0..5];
$s = sprintf '%04d-%02d-%02dT%02d:%02d:%02d.%06d%s', 1900 + shift( @time ), 1 + shift( @time ), @time, $us, $tzo // '';
} else {
$s = defined( $tz ) ? gmtime $s + $tz : localtime $s;
substr $s, 19, 0, $tzo if $tzo;
substr $s, 19, 0, sprintf '.%06d', $us // 0;
}
defined wantarray ? $s : say $s;
}
sub Isodate(@) {
local $pl::isodate = 1;
&Date;
}
# turns list of ipv4/6 addresses & hostnames or $_ into /etc/hosts format
# todo comment not found
sub hosts(@) {
require Socket;
package Socket;
my( %res, %name );
my $res = sub {
my( $v4, $name, $aliases, undef, undef, @addr ) = @_;
undef $name{$_} for $name, split ' ', $aliases;
for( @addr ) {
$_ = unpack 'H*', $_;
if( $v4 ) { # make sortable by kind
s/^(?=7f)/g/ or # loopback
}
for( sort keys %res ) {
next if 1 == length; # IPv6 on old perl
my $ip = pack 'H*', substr $_, 1;
::echo 4 == length $ip ? inet_ntoa( $ip ) : inet_ntop( AF_INET6(), $ip ),
sort grep ! /^[0-9.]+$|^(?=.*:)[0-9a-f:]+$/i, keys %{$res{$_}};
}
}
# Fill keydiff arrays
sub keydiff(;$$) {
my $val;
if( @_ > 1 ) {
$val = $_[1];
} else {
chomp( $val = $_ );
}
$KEYDIFF{@_ == 0 ? $1 : $_[0]}[$ARGIND] = $val;
}
sub Keydiff(;$$) {
my $key = $FIELD[@_ == 0 ? 0 : $_[0]];
if( @_ > 1 ) {
keydiff $key, $_[1];
} else {
keydiff $key;
}
}
# trim small values from %NUMBER
sub Number(;$) {
my $n = $_[0] // 2;
$NUMBER{$_} < $n and delete $NUMBER{$_} for keys %NUMBER;
}
# Pipe command to CODE
sub piped(&$@) {
my $code = shift;
open my $fd, "-|", @_ or die "$_[0]: $!\n";
&$code() while <$fd>;
}
sub help(;$) {
if( @_ && ! defined $_[0] ) {
print <<\EOF;
usage: pl {-{BbeE} program} [-o] [-Vversion] [-perlopt...] [--] [main program] [arg ...]
-Aprog map prog over @A (or undef) returning new @A
-bprog & -eprog wrap begin/end program around each file in -n/-p...
-Bprog & -Eprog wrap begin/end program around program in same scope, my-vars work
-o[number] assume "for(@A) { ... }" loop around main program or array of number args
-O[number] like -o, but use $A as loop var
-p[number] print on each loop (also -o/-O) iteration, at most number times
-P[number] like -p, but print only if main program evaluates to true, like grep
pl @BbeE, 'E "$I;$A:$. $_"', @files;
pl_e '', '-n', '', @files;
unBbeE;
s/^.+? //gm;
$copy = $_;
# run pl, expect @F[1, 0] separated by $_[0]
sub pl_F($$) {
at;
my $sep = $_[0];
pl_a { s/^(.+)$sep(.+)$/$2$sep$1/gm } "-Bmy \$j = '$sep'", $_[1], '$_ = pop @F; e join $j, $_, @F', @files;
}
pl_F ' ', '-al';
pl_F ',', '-lF,';
pl_F ':', '-lF:';
s/.+?:[0-9]+ //mg; # reduce to only file contents
t/sort_keys.t view on Meta::CPAN
# chdir to t/
$_ = $0;
s~[^/\\]+$~~;
chdir $_ if length;
require './test.pm';
}
# run pl, shift -B arg, sort list
sub pl_s($@) {
my( $B, @l ) = @_;
local $_ = join '',
map "$_: 0\n", @l;
pl '-B', $B, '@R{@A} = (0) x @A', @l;
}
my @l = qw(0 07 08 a b c aa 0b1 0b2 bb be cc bad babe);
pl_s '', @l;
pl_s '$H = 1', sort { hex $a <=> hex $b } @l;
use warnings;
use strict;
use Test::Simple tests => $::tests;
use IPC::Open3;
system 'env >/run/shm/env; p -3i > /run/shm/p';
my $windows = $^O =~ /^MSWin/;
sub slurp($) {
my( $ret, $n ) = '';
while( $n = sysread $_[0], my $txt, 1024 ) {
$ret .= $txt;
}
unless( defined $n ) {
$ret .= "sysread: $!";
}
$ret =~ tr/\r//d if $windows;
$ret;
}
# remember outermost caller, so ok() will show original location
my $at;
sub at {
$at //= sprintf '#line %d "%s"', (caller 1)[2, 1];
}
# name and result to compare with $_
sub test($$) {
at;
my( $name, $ret ) = @_;
if( $ret eq $_ ) {
ok 1, $name;
} elsif( $ENV{HARNESS_ACTIVE} ) { # make cpan tester show result
$ret =~ s/\e/\\e/g;
s/\e/\\e/g;
eval $at . q{
ok 0, "$name'\ngot: '$ret'\nexpected: '$_";
};
} else {
eval $at . q{
ok 0, $name;
};
print qq{# got: "$ret"\n# expected: "$_"\n\n}
}
undef $at;
}
# run pl, expect $_
sub pl(@) {
at;
my @cmd = ($^X, '-W', '../pl', @_);
my $name = join ' ', 'pl', map /[\s*?()[\]{}\$\\'";|&]|^$/ ? "'$_'" : $_, @_;
if( $windows ) {
require Win32::ShellQuote;
$cmd[2] = '..\pl';
@cmd = $name = Win32::ShellQuote::quote_native( @cmd );
}
my $none = '';
my $pid = open3( $none, my $fh, '', @cmd );
test $name,
slurp $fh;
waitpid $pid, 0;
}
# run pl, expect shift
sub pl_e($@) {
at;
local $_ = shift;
&pl;
}
# run pl, expect $_ altered by shift->()
sub pl_a(&@) {
at;
local $_ = $_;
shift->();
&pl;
}
1;
( run in 0.343 second using v1.01-cache-2.11-cpan-65fba6d93b7 )