Skip to content

Instantly share code, notes, and snippets.

Last active November 9, 2023 20:49
Show Gist options
  • Save DeeNewcum/8faaf6512a1cea04f63d31a9ab4abe81 to your computer and use it in GitHub Desktop.
Save DeeNewcum/8faaf6512a1cea04f63d31a9ab4abe81 to your computer and use it in GitHub Desktop.
Perl snippets that I sometimes copy-and-paste
# These are minified versions of Perl routines, intended to be easy to copy-n-paste into Perl scripts.
# 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)
# 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)}
# 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)}
# like readpipe_args(), but it runs chomp() on every line returned
sub readpipe_args_chomp {wantarray&&return map{chomp;$_}readpipe_args(@_);$_=readpipe_args(@_);chomp;$_}
# 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"}}
# ^^^ 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;};
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.
#>> (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
#>> 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;
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment