#!/usr/bin/perl

use strict;
use warnings;

use List::Util qw( first );

my $usage = "$0 <format source>";
my $format_file = shift @ARGV || die $usage;

# The "format" is some shape made with "#" symbols.
my $format = wholefile( $format_file );
$format =~ s{ \s+ \n }{\n}xmsg;
my $format_char_count = ($format =~ tr/#//
                );

# Program text, at least the size of the format
my $src = wall_text( $format_char_count );

my @src_chars = split //, $src;

# There is some program text that won't fit in the format.
my $overflow_char_count = scalar @src_chars - $format_char_count;
if ( $overflow_char_count < 0 ) {
    die 'not enough program text';
}

my $out = '';
my $line_width = 70;

# I take half the overflow text and put it at the beginning
# in lines a full $line_width wide.
my $prewall_size = $overflow_char_count / 2;
while ( $prewall_size > $line_width ) {
    $out .= join '', splice( @src_chars, 0, $line_width );
    $out .= "\n";
    $prewall_size -= $line_width;
}
$out .= "\n";

# Replace the format with program text, and add that to the output.
$format =~ s/#/shift @src_chars/eg;
$out .= $format;
$out .= "\n\n";

# Add the remaining program text to the end in $line_width wide lines.
while ( @src_chars ) {
    $out .= join '', splice( @src_chars, 0, $line_width );
    $out .= "\n";
}

print "$out\n";

# The resulting program actually won't run as-is.
# It has a newline in a spot that it shouldn't.
# You have to edit the resulting file to reform
# the live code that trails after all the text.

if (0) {
    no warnings;
    eval $out;
}

exit;

sub mkprog {
    my $old_prog = shift;

    my $salt = salt_finder();
    my $encoded = encode( $old_prog, $salt );

    # possible delimiters, in order of preference
    my @delim = split //, q{,.=_-#!%^*|};
    # use the first one that doesn't appear in the encoded text
    my $chosen_delim = first { -1 == index $encoded, $_ } @delim;

    my $new_prog;
    $new_prog = "\$_=+q$chosen_delim$encoded$chosen_delim,\$#='$salt',
+";
    $new_prog .= 's|\\S|substr crypt($&,$#),length$#,length$&|ge,';
    $new_prog .= "\$#='';";
    $new_prog .= 's,..,chr hex$&,ge,$#.=$_ for split';
    $new_prog .= ';eval$#';

    return $new_prog;
}

# This was used during initial debugging.
# It's kept here for reference.
sub decode {
    my ( $str, $salt ) = @_;

    $str =~ s/(.)/substr crypt( $1, $salt ), 2, 1/ge;
    $str =~ s/(..)/chr hex $1/ge;

    return $str;
}

sub encode {
    my ( $str, $salt ) = @_;

    my %src_for;
    # $ord takes tha ASCII code of each visible character
    foreach my $ord ( 33 .. 126 ) {
        my $c = chr $ord;
        next if $c eq '\\';   # backslash "messes up" q()
        my $crypted = crypt $c, $salt;
        # I'm looking for things where the third char is a hex digit
        next unless $crypted =~ /^..[a-f0-9]/;

        # this hex digit can be made by crypting this ASCII char
        push @{$src_for{substr $crypted, 2, 1}}, $c;
    }

    my $encode_one = sub {
        # the two-digit hex for this character
        my $hex = sprintf '%x', ord shift;

        # For each hex digit, select a random character
        # that crypts to it.
        my @srces;
        $hex =~ s{(.)}{@srces = @{$src_for{$1}};$srces[rand @srces];}g
+e;
        
        return $hex;
    };

    $str =~ s/(.)/$encode_one->($1)/ge;

    return $str;
}

# not every salt can produce every hex digit
# this uses a loop a lot like encode(), but it's checking whether
# it found every digit or whether it needs to pick a new salt.
sub salt_finder {
    my @alphabet = ( 'a' .. 'z', 'A' .. 'Z', '0' .. '9' );

    my %src_for;
    my $salt;
    
    while ( scalar keys %src_for != 16 ) {
        %src_for = ();
        $salt = $alphabet[rand @alphabet] . $alphabet[rand @alphabet];

        foreach my $ord ( 33 .. 126 ) {
            my $c = chr $ord;
            next if $c eq '\\';
            my $crypted = crypt $c, $salt;
            next unless $crypted =~ /^..[a-f0-9]/;
            $src_for{substr $crypted, 2, 1}++;
        }
    }

    return $salt;
}

sub wall_text {
    my ( $min_length ) = @_;
    
    my $prog = q{print "Just another Perl hacker,\\n"};

    while ( length $prog < $min_length ) {
        $prog = mkprog( $prog );
    }

    return $prog;
}

sub wholefile {
    my ( $file ) = @_;
    
    open my $fh, '<', $file
        or die "Can't read '$file': $!";
    my $wholefile = do { local $/; <$fh> };
    close $fh or die "close failed: $!";

    return $wholefile;
}
[download]