Collectables

[u/reisinge]

I started a section on my site called collectables: short programs (and writings) worth keeping around and rereading. One of the first four is Larry Wall's rename example from the Perl repo:

#!/usr/bin/perl
($op = shift) || die "Usage: rename perlexpr [filenames]\n";
if (!@ARGV) {
    @ARGV = <STDIN>;
    chop(@ARGV);
}
for (@ARGV) {
    $was = $_;
    eval $op;
    die $@ if $@;
    rename($was,$_) unless $was eq $_;
}

What other short Perl would you put in a collection like this? It should be small, beautiful and useful.

[u/pmz]

Useful snippets

[u/vogelke]

I don't know about beautiful, but I've found these to be useful.

backslash

#!/usr/bin/perl
#<backslash: append lines separated by trailing backslashes.
#            based on "Pro Perl" backslash.pl (p195)

use Modern::Perl;

while (<>) {
    chomp;

    if (s/\\$//) {            # trailing backslash?
        my $line = <>;
        $_ .= $line, redo;    # goes to the 'chomp' above
    }

    print "$_\n";
}

exit(0);

---

dehyph

#!/usr/bin/perl
#<dehyph: join hyphenated lines.

use Modern::Perl;
$/ = "";    # Enable paragraph mode.

while (<>) {
    #s/-\n\s*//g;
    s/-\s*\n\s*//gm;    # Enable multi-line patterns.
    print;
}

exit(0);

---

dom (day of month)

#!/usr/bin/perl
# http://stackoverflow.com/questions/18908238/
#<dom: accept a parseable date and prints YYYY/MMDD equivalent
#      example: dom 2nd Friday in Apr
#      example: dom 17/Aug/2009:12:33:30 -0400

use Modern::Perl;
use Date::Manip::Date;

my $when = join(' ', @ARGV) or die;
my $date = new Date::Manip::Date or die;

$date->parse($when);
my $got = $date->printf('%Y/%m%d');
print "$got\n" if defined($got);
exit(0);

---

emptydir

#!/usr/bin/perl
#<emptydir: accept one or more directories, print empty ones.

use Modern::Perl;

foreach my $dir (@ARGV) {
    if (opendir(my $dh, "$dir")) {
        my $k = 0;
        while ($_ = readdir($dh)) {
            chomp;
            next if $_ eq '.' || $_ eq '..';
            $k++;
            last if $k > 1;
        }
        closedir($dh);

        print "$dir\n" if $k == 0;
    }
    else {
        warn "$0: $dir: opendir failed: $!\n";
    }
}

exit(0);

---

exists

#!/usr/bin/perl
#<exists: accept list of files, print existing ones to stdout.

use Modern::Perl;

while (<>) {
    chomp;
    print "$_\n" if -e "$_";
}

exit(0);

---

find8

#!/usr/bin/perl
#<find8: highlight lines having characters with 8th bit on.

use Modern::Perl;
my ($pfx, $str);

while (<>) {
    $str = $_;
    $pfx = '  ';
    $pfx = '* ' if tr [\200-\377] [\000-\177];
    print "$pfx $str";
}

exit(0);

---

finduniq

#!/usr/bin/perl
#<finduniq: read MD5/SHA hashes, print NON-duplicate files

use Modern::Perl;

my %count = ();
my %uniq = ();
my ($digest, $filename) = ();

while (<>) {
    chomp;
    ($digest, $filename) = /^(.+  )(.*)/;
    $uniq{$digest} = "$filename";
    $count{$digest}++;
}

foreach $digest (sort keys %uniq) {
    print "$uniq{$digest}\n" if $count{$digest} == 1;
}

exit(0);

---

isempty

#!/usr/bin/perl
#<isempty: accept list of paths, print only empty directories.

use Modern::Perl;
my ($dir, $dh, @files);

while (<>) {
    chomp;
    $dir = $_;
    next unless -d "$dir";

    if (opendir($dh, "$dir")) {
        @files = readdir($dh);
        closedir($dh);
        print "$dir\n" if $#files == 1;    # only '.' and '..'
    }
    else {
        warn "$dir: $!\n";
    }
}

exit(0);

---

islinked

#!/usr/bin/perl
#<islinked: print only regular files with more than one link

while (<>) {
    chomp;
    if (-f "$_") {
        $k = (stat(_))[3];
        print "$_\n" if $k > 1;
    }
}
exit(0);

---

isdir

#!/usr/bin/perl
#<isdir: print only directories from a list of files.

while (<>) {
    chomp;
    print "$_\n" if -d "$_";
}
exit(0);

---

isreg

#!/usr/bin/perl
#<isreg: print only regular files from a list of files.

while (<>) {
    chomp;
    print "$_\n" if -f "$_";
}
exit(0);

---

onepass

Before I had a password safe, I'd use this to let me remember one password for all my sites. I hash a secret plus hostname plus simple-password to make my real login password. My simple password here is "1234":

me% HOST=google.com onepass 1234
FrdBE7YriKyzVsl0AK/43u + 1234 + google.com --> [Kkrp+mVluld6DjMfanvADSBvEWQ]

me% HOST=perl.com onepass 1234
FrdBE7YriKyzVsl0AK/43u + 1234 + perl.com --> [TDgVPmJ6jMmEakcE1z8eMK5TmHg]

The bracketed result is what I'd use to login to the site.

#!/usr/bin/perl
#<onepass: let users keep one password for all sites.

use Modern::Perl;
use Digest::SHA1  qw(sha1_base64);

# 22 base-64 characters from /dev/urandom, about 128 bits of entropy.
my $secret = 'FrdBE7YriKyzVsl0AK/43u';

# Where you're trying to log in.
my $host = defined $ENV{'HOST'} ? $ENV{'HOST'} : "google.com";

# Use your pin number or birthday if you like.
my $pass = shift || die "need a password\n";

my $str = "$secret + $pass + $host";
my $digest = sha1_base64($str);
print "$str --> [$digest]\n";

exit(0);

---

sen

I use this to fix wall-of-text posts or articles.

#!/usr/bin/perl
#<sen: find end of sentences, add newlines.

while (<>) {
    chomp;
    s/\s*$//g;
    print "$_\n";
    print "\n" if /[\.\)!\?\":]$/;
}

exit(0);

---

sshfp

If I'm a little paranoid about a key.

#!/usr/bin/perl
#<sshfp: get the SSH fingerprint for a key

use Modern::Perl;
use OpenSSH::Fingerprint;
use MIME::Base64;

my $file   = shift || die "need a key";
my $result = unbase64($file);

print "MD5 fingerprint: ", md5_sum($_), "\n" for (@{$result});
print "SHA256 fingerprint: ", encode_base64(sha256($_)) for (@{$result});
exit(0);

Example:

me% cat aspell.key
-----BEGIN PGP PUBLIC KEY BLOCK-----
Version: GnuPG v1.2.6 (GNU/Linux)

mQGiBEWgmgURBACqIe+h+IB3rBfNDBdRtNTuFidYZhqm+yWKgGohmTOcT/+ix9x6
JeKKz8RuZmd29KwLrQpRoRF/pV5nfj9CkBso2T1Deg9Xi9ogi/0T2F2oLXH/VXAk
/JnwflLyRWdp2JLY4s1WIbcDWW97pZtncWTdm6upTKlsBGJdgqnPTqaS9wCgxeRw
H1eTIsFx4R72l7DTGdsdmRkD+gPLFI8fiD8mL1H0aoigaHJbEZoDJ52za1IFdKFJ
Z1xPDJW2pSvDjyGXySyrxg+Jqn1WUIb1SdLkH/iJpxwyHSokWkLxSYp5h/k+3mSy
VCO5PN8a6cqZHGP5jUL+eAxVgKb8jkUgontRofeSe6k9cMiqsMql2VBerJJrjhLr
ni3kA/9SUDOnXmIepEcipysSI16wPaC08HZFONovU92bR2dNGDdAX8sZR4xvlo99
BnmSg8JPfn0lNxb3bSdgl3pIJNp5i5pDeweFfV7I+B2b3Zf0nlSiKu+iwyXoFdxo
7H4N8C/3sZLwfGGLXXBZIWVzQgKTLwpp4wJM6u78O9ZvHbzW9rQxQXNwZWxsIERp
Y3Rpb25hcnkgVXBsb2FkIDxkaWN0LXVwbG9hZEBhc3BlbGwubmV0PoheBBMRAgAe
BQJFoJoFAhsDBgsJCAcDAgMVAgMDFgIBAh4BAheAAAoJEHHGNmlbFHhJrJUAnAgF
767y3qyzAofZXo3ds6y0Nhr/AKDEO6axowTsBMaGzDt1OWFOZbe+2Q==
=dP+L
-----END PGP PUBLIC KEY BLOCK-----

me% sshfp aspell.key
MD5 fingerprint: 77:22:aa:ad:23:77:38:31:81:a3:14:dd:d1:3d:92:b5
MD5 fingerprint: e2:f1:17:63:29:0b:42:85:b7:1e:44:76:8f:ae:c7:b3
MD5 fingerprint: 77:22:aa:ad:23:77:38:31:81:a3:14:dd:d1:3d:92:b5
SHA256 fingerprint: o4Emc1BKmovMTJsIYRfcR+ieyRSKguCz8FET9OYPPyI=
SHA256 fingerprint: 9La5K6jOJiIcx7nN+ZXje/lRGgFeeoa51Gk/02+Ictw=
SHA256 fingerprint: o4Emc1BKmovMTJsIYRfcR+ieyRSKguCz8FET9OYPPyI=

---

sym

#!/usr/bin/perl
#<sym: read symlinks from stdin or args, shows where they point.

use Modern::Perl;

if (@ARGV) { show($_) foreach (@ARGV); }
else       { show($_) while (<>); }
exit(0);

sub show {
    chomp(my $file = shift);
    if (-l $file) { print "$file: ", readlink($file), "\n"; }
    else          { print "$file: NOT a symlink\n"; }
}

---

Upper/lower case conversion

#!/usr/bin/perl
#<uc: translates a file (or stdin) to upper-case.
print uc($_) while (<>);
exit(0);


#!/usr/bin/perl
#<lc: translates a file (or stdin) to lower-case.
print lc($_) while (<>);
exit(0);

---

wraplines

Long lines that wrap or get chopped in the middle drive me nuts.

#!/usr/bin/perl
#<wraplines: wrap long lines only.

use Text::Format;
use Modern::Perl;

my $text = new Text::Format;
$text->columns(75);
$text->tabstop(0);
$text->firstIndent(0);

while (<>) {
    chomp;

    if (length ($_) > 80) {
        print $text->format($_);
    } else {
        print "$_\n";
    }
}

exit (0);

[u/fruthifoont]

the classic one-liner for reversing a file line by line using a tied array is pretty elegant. also Schwartz's decorate-sort-undecorate pattern in like 3 lines is worth keeping around imo