Encrypting and decrypting IBM WebSphere passwords using perl

As most of the IBM WebSphere admistrators know, the passwords stored in the various xml configuration files
are merely obscured but not really encrypted.
Nevertheless, sometimes you need to decrypt the password or fix a broken password fast by changing it.

So I wrote myself a little perl script that does just that for me: Encrypt and Decrypt IBM WebSphere passwords:
(And it runs on AIX machines with ancient perl :)

#!/usr/bin/perl

# Project:      waspass
# Date:         Thu Jan  8 15:04:53 CET 2009
# Author:       Nicholas Stallard
# Description:  encodes/decodes IBM Websphere passwords 

### enforce clean programming ###
use warnings;
use strict;

### other modules used ###
use Getopt::Long;
use File::Basename;

# variables
my $password;           # string        # the encoded/decoded password

# program name and version
my $PROGNAME   = lc basename($0);
my $CVSVERSION = '$Revision: 1.6 $';

# if no argument is supplied, display help
if (@ARGV == 0)
{
    my ($version) = $CVSVERSION =~ /(\d\S+)/;
    print "$PROGNAME $version\n";
    print "\n";
    print "Usage: $PROGNAME \n";
    print "\n";
    print "This decodes or encodes (autodetect) an IBM Websphere password.\n";
    print "\n";
    exit 0;
};

# grab the first argument, ignore the rest
$password=$ARGV[0];

# decode if encoded, encode, if plain text
if    ($password =~ s/{xor}(.*)/$1/) { print decode($password); }
else                                 { print encode($password); };

exit 0;

### subroutines ###

# subroutine taken from the 9.18 perl FAQ
# minor modifications
sub decode
{
        my ($string) = @_;
        my $len;
        my $tempstring;
        my @chars;

        # basic uudecode, string must not exceed 86 bytes

        $string     =~ tr#A-Za-z0-9+/##cd;
        $string     =~ tr#A-Za-z0-9+/# -_#;
        $len        =  pack("c", 32 + 0.75*length($string));
        $tempstring =  unpack("u", $len . $string);          

        return ibmxor($tempstring)."\n";
};

# subroutine from MIME::Base64 (native implementation)
# with minor modifications
sub encode
{
    my $string = $_[0];
    my $eol    = $_[1];

    my $res;
    my $padding;

    $eol        = "\n" unless defined $eol;

    $string     = ibmxor($string);

    $res        = pack("u", $string);

    # Remove first character of each line, remove newlines
    $res        =~ s/^.//mg;
    $res        =~ s/\n//g;
    $res        =~ tr|` -_|AA-Za-z0-9+/|;               # `

    # fix padding at the end
    $padding    =   (3 - length($string) % 3) % 3;
    $res        =~  s/.{$padding}$/'=' x $padding/e if $padding;

    # break encoded string into lines of no more than 76 characters each
    if (length $eol)
    {
        $res =~ s/(.{1,76})/$1$eol/g;
    };

    return "{xor}",$res;
}

# XOR a string with 0x5f
sub ibmxor
{
        my ($string) = @_;
        my @chars;

        @chars = unpack('C*', $string);
        for my $cnt (0 .. $#chars) { $chars[$cnt] ^= 0x5f; };

        return pack('C*', @chars);
};