shortcat

shortcat

#!/usr/bin/perl
use 5.014;
our $VERSION = 0.001;

use strict;
use warnings;
use autodie;

use Carp qw(carp croak);
use File::Basename qw(dirname);
use File::Temp;
use File::stat;
use Getopt::Long qw(GetOptions);
use Pod::Usage qw(pod2usage);

use constant BUFSZ => 4096;

my $stdout;
my $decode;
my $force;
my $keep;
my $help;
my $suffix = '.shortcat';

Getopt::Long::Configure qw(gnu_compat bundling auto_version auto_help);
GetOptions(
    'stdout|c' => \$stdout,
    'decode|d' => \$decode,
    'force|f' => \$force,
    'keep|k' => \$keep,
    'suffix|S=s' => \$suffix,
) and !$keep || length $suffix or pod2usage(2);

if (@ARGV) {
    for my $inn (@ARGV) {
        open my $in, '<:mmap', $inn;
        my ($stat, $outn);
        unless ($stdout) {
            $stat = stat $in;
            croak("Refusing to remove ``$inn'' with multiple links (use --force)")
                if !$force && !$keep && $stat->nlink > 1;
            $outn = $decode ? $inn =~ s/\Q$suffix\E\Z//r : $inn . $suffix;
            my $st = lstat($outn);
            croak("Cannot replace directory ``$outn''") if $force && $st && -d $st;
            croak("Refusing to overwrite ``$outn'' (use --force)") if !$force && $st && -e $st;
        }
        my $out = $stdout ? *STDOUT : File::Temp->new(
            TEMPLATE => ".XXXX", DIR => dirname($inn), SUFFIX => ".sc", UNLINK => 1);
        unless ($stdout) {
            chmod $stat->mode, $out;
            chown $stat->uid, $stat->gid, $out;
        }
        process($in, $out);
        unless ($stdout) {
            rename $out->filename, $outn;
            File::Temp::unlink1($in, $inn) or croak("Failed to unlink ``$inn'': $!") unless $keep;
        }
    }
} else {
    open my $in, '<&STDIN';
    open my $out, '>&STDOUT';
    process($in, $out);
}

sub process {
    my ($in, $out) = @_;
    binmode $in, $decode ? ':utf8' : ':raw';
    binmode $out, $decode ? ':raw' : ':utf8';
    my $buffer;
    while (sysread $in, $buffer, BUFSZ) {
        if ($decode) {
            $buffer =~ tr/\x{2500}-\x{25ff}//cd;
            $buffer =~ tr/\x{2500}-\x{25ff}/\0-\377/;
        } else {
            $buffer =~ tr/\0-\377/\x{2500}-\x{25ff}/;
        }
        syswrite $out, $buffer;
    }
}

__END__

=head1 NAME

shortcat

=head1 SYNOPSIS

shortcat [OPTION]... [FILE]...

=head2 Options

  -c, --stdout
  -d, --decode
  -k, --keep
  -S, --suffix=.shortcat

=head1 SEE ALSO

Nick Monfort's
L<shortcat introduction|https://twitter.com/nickmofo/status/612427141205069824>,
L<encoder|https://twitter.com/nickmofo/status/612427769608335360>,
and L<decoder|https://twitter.com/nickmofo/status/612430005352693760>