Perl snippets that I sometimes copy-and-paste
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
# 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. | |
#>> (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)}} | |
# 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; | |
} | |
} |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment