Perl snippets that I sometimes copy-and-paste

snippets.pl

# These are minified versions of Perl routines, intended to be easy to copy-n-paste into Perl scripts.
#       http://en.wikipedia.org/wiki/Minification_(programming)
#
# I acknowledge that these go against numerous coding principles:
#       - DRY
#       - compactness hinders readability and maintainability
#       - using cut-n-paste instead of libraries means that bugs will stick around longer because bugfixes
#         are MUCH harder to distribute
#       - this code is tested by only one person, and so is far less mature than CPAN code
# But there's one upside to copy-n-pasting minified functions:
#       - It allows scripts to be easily run across the many computers that I work on.  It allows
#         the scripts to be portable and self-contained, and run without having to install any
#         dependencies.  (on some systems, I'm unable to install libraries for various reasons)
#                   http://paperlined.org/dev/perl/portability.html
#
# Of course, whenever possible, scripts should use a CPAN library that provides the equivalent
# functionality.
#
# Failing that, if possible, scripts should use App::FatPacker to use CPAN libraries.  This allows
# them to be self-contained and as easy to run on a computer as a portable app, yet still rely on
# mature tested code.


#>> Lines with  #>>  are intended to NOT be copy-n-pasted


sub trim {my@a=map{(my$s=$_)=~s/^[\s\n\r]+|[\s\n\r]+$//gs;$s}@_;wantarray?@a:$a[0]}

# Like qw[...], but breaks on lines instead.  Ignores comment lines (lines that start with a hash symbol).
sub ql {map{s/^\s+|\s+$//gs;$_}grep/^\s*[^#\s]/,split/[\n\r]+/,shift}
    #>>  below is a variant that has different comment-handling features.
                                                                                  #>> vv  because there's no mechanism for hash-escaping, hash symbols can't be used anywhere in normal text
# Like qw[...], but breaks on lines instead.  Comments (hash symbol) are ignored, and can occur anywhere in a line.
sub ql {map{s/\s+#.*|#.*|^\s+|\s+$//gs;$_}split/[\n\r]+/,shift}

# Like qw[...], but it allows comments (hash symbol).
#                       #>> same caveat as with 2nd ql() -- because we allow comments to start anywhere on a line, this prevents us from using hash anywhere within normal text.
sub qw_cmnt {local$_=shift;s/\s+#.*//gm;split}


# Does the opposite of what List::MoreUtils::zip() does.
#       split [1,'a',2,'b',3,'c'] into [[1,2,3],['a','b','c']]
# Think more "zipper" and less "a compression algorithm".
sub unzip {my($i,$j)=(0,0); [grep{++$i%2}@_],[grep{$j++%2}@_]}


    #>> YOU REALLY SHOULD USE Path::Tiny's slurp*() OR lines*() ROUTINES INSTEAD.
# quickly read a whole file
sub slurp {open(my$f,"$_[0]")or die$!;my@o=<$f>;close$f;wantarray?@o:join("",@o)}

    #>> YOU REALLY SHOULD USE ONE OF THESE INSTEAD -- https://paperlined.org/dev/perl/modules/related_modules/capture_output_from_command.md
# like qx// or readpipe(), BUT it allows you to give explicitely delimited args, so you don't have to worry about escaping quotes
sub readpipe_args {open(my$f,'-|',@_)or die$!;my@o=<$f>;close$f;wantarray?@o:join("",@o)}

    #>> YOU REALLY SHOULD USE ONE OF THESE INSTEAD -- https://paperlined.org/dev/perl/modules/related_modules/capture_output_from_command.md
# like readpipe_args(), but it runs chomp() on every line returned
sub readpipe_args_chomp {wantarray&&return map{chomp;$_}readpipe_args(@_);$_=readpipe_args(@_);chomp;$_}

    #>> YOU REALLY SHOULD USE ONE OF THESE INSTEAD -- https://paperlined.org/dev/perl/modules/related_modules/capture_output_from_command.md
# like qx// or readpipe(), BUT it allows complete control over what the child pid does between
# forking and execing...  you pass it a subroutine that gets run just after forking
sub readpipe_ultimate {my$s=shift;defined(my$p=open(my$f,'-|'))or die$!;if(!$p){&$s;exec@_ or die$!}my@o=<$f>;close$f;waitpid($p,0);wantarray?@o:join("",@o)}
    #>> The subroutine is the first argument.  Example contents of that subroutine:
    #>>       readpipe_ultimate(sub {
    #>>           $ENV{FOO} = 'bar';
    #>>           open STDERR, '>', '/dev/null';
    #>>       }, 'find', '/');


# Simplified version of getopt -- allows ANY dash-argument, each can take an optional parameter.
#       Example command line:       -a -b --flag1 --flag2 value2 --flag3 value3
#       (also, switch-clustering isn't allowed, nor are repeats of the same argument)
# Somewhat equivalent to Getopt::Casual
            #>>   (example call)        %::ARGV = getopt_simple();     # there are NO arguments
sub getopt_simple {my($p,$_p)=1;map{($_p,$p)=($p,1);if(/^-/){($_,$_p)}else{$p=$_;()}}reverse@ARGV}


# Returns true if the specified flag is present, and if so, removes it from @ARGV.
# This allows you to call it several times, checking for different flags on each call.
            #>>   (example call)        if (getopt_flag('--verbose')) { ... }
sub getopt_flag {my($a,$b)=(shift,~~@ARGV);@ARGV=grep{$_ ne$a}@ARGV;$b!=~~@ARGV}
    # TODO:  write getopt_flag_with_argument(), that's the same as above, but works for flags that 
    #        take an argument



# add commas to a number
sub commify {(my$text=reverse$_[0])=~s/(\d\d\d)(?=\d)(?!\d*\.)/$1,/g;scalar reverse$text}


# equivalent to Data::Dumper::Perltidy
use Data::Dumper();   use Perl::Tidy;
sub Dumper {perltidy source=>\(Data::Dumper::Dumper@_),destination=>\(my$t);$t}


# Syntactic sugar -- lets you initialize a hash like you normally would, but it also returns the order of the keys.
            #>>     (example call)      my ($key_order_listref, %hash) = ordered_hash(    key => val, key => val  );
sub ordered_hash {my$n;my@order=grep{!($n++%2)}@_;(\@order,@_)}

# Removes duplicate elements from a list
sub uniq {my %seen; grep {!$seen{$_}++} @_}

# equivalent to String::Interpolate or Text::Template
# (except String::Interpolate requires Perl v5.8.2, and Text::Template requires 'our' variables instead of 'my')
sub interpolate {(my$ZZZ=shift)=~s/([\\"])/\\$1/g;eval qq{"$ZZZ"}}
sub interpolate {eval qq{<<"ASEFJERGJERJJWLKFDLGBKJLJGIEASPOVBLKSDJFLASJWEIFJSDIVJV"\n$_[0]\nASEFJERGJERJJWLKFDLGBKJLJGIEASPOVBLKSDJFLASJWEIFJSDIVJV}}
        # ^^^ yeah, I think the second one is better...  the first one gives you zero ability to escape %'s or @'s or $'s

# Read __DATA__ section using another method than <DATA>
            #>>      (parameter 1)     filename        specify $0 if you want the starting script's __DATA__ section
sub data_section {open my$fin,"<$_[0]";local$/="\n__DATA__\n";<$fin>;local$/=undef;<$fin>}

# display a string to the user, via `xxd`
sub xxd {open my$xxd,"|xxd"or die$!;print$xxd $_[0];close$xxd}
# same, but whenever we might run across utf8 data
use Encode;
sub xxd {Encode::_utf8_off(my$str=shift);open my$xxd,'|-','xxd'or die$!;print$xxd $str;close$xxd}    


# display a string to the user, via 'less'
sub less {my$pid=open my$less,"|less";print$less @_;close$less;waitpid$pid,0}

# display a string to the user, via vim    (note: first arg is a .vimrc command;  use the empty-string if it's unneeded)
sub vim {my$pid=open my$vim,"|-",'vim','-R','-c',shift,'-';print$vim @_;close$vim;waitpid$pid,0}
                #>>     (example)           vim('set syntax=perl', Dumper($data_structure));

        # pretty-print JSON
        sub dump_json {vim('set syntax=javascript', JSON::PP->new->pretty->encode(@_))}

# use vim as a $PAGER for this program's output      (optional arg is a .vimrc command)
BEGIN {my$pid; sub PAGER_vim {$pid=open STDOUT,"|-",'vim','-R','-c',shift||'','-'} END{close STDOUT;waitpid($pid,0)if$pid}}

# use less as a $PAGER for this program's output
BEGIN {my$pid; sub PAGER_less {$pid=open STDOUT,"|-",'less','-',@_} END{close STDOUT;waitpid($pid,0)if$pid}}




                #>> useful for things like `xmllint`, `xxd`, etc
# run a scalar through an external filter, and capture the results
# first arg is a list-ref that specifies the filter-command
use autodie;
sub filter_thru {my$pid=open my$fout,'-|'or do{my$pid=open my$fin,'|-',@{shift()};print$fin @_;close$fin;waitpid$pid,0;exit;};
                 my@o=<$fout>;close$fout;waitpid$pid,0;wantarray?@o:join'',@o}

sub xxd {filter_thru(['xxd'],@_)}



# check if the given function exists  (and, if so, it returns a pointer to it)
no strict 'refs';
sub function_exists {defined&{$_[0]}?\&{$_[0]}:undef}
use strict 'refs';


# do a syntax check on a piece of Perl code that you'll pass to eval() later; confirm it compiles okay; returns false if there's a syntax error
sub syntax_check {defined(my$p=open(my$f,'-|'))or die$!;if(!$p){open STDIN,"/dev/null";open STDERR,"/dev/null";exec$^X,"-c","-e",$_[0]}waitpid($p,0);my$r=$?;close$f;!($r>>8)}


# a version of Data::Dumper that's useful in CGI scripts
sub cgi_dumper {print"<pre>",CGI::escapeHTML(join("",Dumper(@_))),"</pre>"}
    
    # or a variation of that, that will also just print plain strings (properly quoted), if you just pass it that
    sub cgi_dumper {print'<pre>',CGI::escapeHTML(@_>1||ref($_[0])?join('',Dumper(@_)):$_[0]),'</pre>'}

# a version of Data::Dumper that's useful in PSGI/Plack scripts
sub plack_dumper { [200, ['Content-Type', 'text/plain'], [Dumper @_]] }
sub plack_text { [200, ['Content-Type', 'text/plain'], \@_] }

# a version of Data::Dumper that's suitable for use as a Dancer page-return
                #>>   (example)  (within a Dancer URL-handler)
                #>>                         return dancer_dumper(\@my_struct);
sub dancer_dumper {'<pre>'.Plack::Util::encode_html(join'',Dumper@_).'</pre>'}



# DBI has selectall_arrayref() and selectall_hashref(), but no selectall_listofhashes().  Fix that.
# Accepts the same inputs that DBI's selectall_arrayref() does.    https://metacpan.org/pod/DBI#selectall_arrayref
                #>>  (these revolve around the fact that when we pass a hash-reference into $slice,
                #>>   DBI does exactly what we want)
sub DBI::db::selectall_listofhashes {my($dbh,$stmt,$attr,@bind)=@_;@{$dbh->selectall_arrayref($stmt,{%{$attr||{}},Slice=>{}},@bind)}}
sub DBI::st::fetchall_listofhashes {my($sth,$max_rows)=@_;@{$sth->fetchall_arrayref({},$max_rows)}}
                #>> my @rows = $dbh->selectall_listofhashes("SELECT ....");



# Excerpted from List::Util.  Should be mature and mostly bug-free.
{no strict; sub reduce(&@) {$s=shift;@_>1||return$_[0];$c=caller;local(*{$c."::a"})=\my$a;local(*{$c."::b"})=\my$b;$a=shift;for(@_){$b=$_;$a=&{$s}()}$a}}
sub sum (@) { reduce { $a + $b } @_ }
sub min (@) { reduce { $a < $b ? $a : $b } @_ }
sub max (@) { reduce { $a > $b ? $a : $b } @_ }
sub minstr (@) { reduce { $a lt $b ? $a : $b } @_ }
sub maxstr (@) { reduce { $a gt $b ? $a : $b } @_ }



# Tries to 'require' the specified list of modules, and provide a
# user-friendly error if any aren't found.
   #>> Example call at the top of https://github.com/DeeNewcum/dotfiles/blob/master/bin/0excerpt
   #>> 
   #>> It would be better to instead use the popular and well-tested Module::Runtime.
sub can_require {
    my @modules_requested = @_;

    my @modules_not_found;
    foreach my $module (@modules_requested) {
        eval "require $module";
        if ($@) {
            if ($@ =~ /^Can't locate /s) {
                push @modules_not_found, $module;
            } else {
                warn $@;
                exit 1;
            }
        }
    }

    # show the full list of modules not installed, at the end
    if (@modules_not_found) {
        print STDERR "The following module(s) are required but not installed:\n";
        print STDERR "\t", join(" ", @modules_not_found), "\n";
        exit 1;
    }
}                                          


# Convert a duration (in seconds) to a human-readable string.
# Better alternatives include Time::Duration, Time::Duration::Concise, and Time::Duration::Locale.
sub duration_to_human {
    my ($x) = @_;
    ($x < 0) and return "-" . duration_to_human(-$x);
    ($x < 1) and return sprintf("%.2f ms", $x*1000);
    ($x < 100) and return sprintf("%.2f sec", $x);
    ($x < 6000) and return sprintf("%.2f min", $x/60);
    ($x < 108000) and return sprintf("%.2f hrs", $x/3600);
    ($x < 400*24*3600) and return sprintf("%.2f days", $x/(24*3600));
    return sprintf("%.2f years", $x/(365.25*24*3600));
}