make apple .plist files more readable, translating them to perlish

xml2pl.pl

#!/usr/bin/perl -w
# (C)2009 Willem Hengeveld  [email protected]
use strict;
use MIME::Base64;
local $/;

# script to convert macosx .plist xml files to perl, this makes them much more readable
# NOTE: there is also  "/usr/libexec/PlistBuddy -c Print  x.plist"
#
#
# with the below commented out perl code, you can then execute the generated perl in your perl interpreter.

# use strict;
# use warnings;
# use Data::Dumper;
# $Data::Dumper::Sortkeys= 1;
# $Data::Dumper::Indent= 1;
# sub plhex { return pack 'H*', $_[0]; }
# sub pldate { return $_[0]; }
# sub true { return 1; }
# sub false { return 0; }
# -> print Dumper( ... )

my %str;
my %int;
my $deref=1;
while (<>) {
    s/<key>(.*?)<\/key>[\s\n\r]*/squote(unescape($1))."=>"/ges;
    s/<string>(.*?)<\/string>/dquote(unescape($1)).","/ges;
    s/<integer(?:\s+size="32")?>(.*?)<\/integer>/$1,/g;
    s/<integer size="64">(.*?)<\/integer>/"$1",/g;
    if ($deref) {
        s/<string ID="(\d+)">(.*?)<\/string>/$str{$1}=$2; dquote(unescape($2)).","/ges;
        s/<string IDREF="(\d+)"\s*\/>/dquote(unescape($str{$1})).","/ges;
        s/<integer\s+ID="(\d+)"(?:\s+size="32")?>(.*?)<\/integer>/$int{$1}=$2; "$2,"/ge;
        s/<integer IDREF="(\d+)"\s*\/>/$int{$1},/g;
    }
    else {
        s/<string ID="(\d+)">(.*?)<\/string>/"[$1,".dquote(unescape($2))."],"/ges;
        s/<string IDREF="(\d+)"\s*\/>/[$1],/gs;
        s/<integer\s+ID="(\d+)"(?:\s+size="32")?>(.*?)<\/integer>/[$1,$2],/g;
        s/<integer IDREF="(\d+)"\s*\/>/[$1],/g;
    }
    s/<real>(.*?)<\/real>/$1,/g;
    s/<date>(.*?)<\/date>/pldate("$1"),/g;
    s/<data>(.*?)<\/data>/sprintf("plhex(\"%s\"),",unpack('H*',decode_base64($1)))/ges;
    s/<dict>/{/g;
    s/<\/dict>/},/g;
    s/<dict\/>/{},/g;
    s/<array>/[/g;
    s/<\/array>/],/g;
    s/<array\/>/[],/g;
    s/<true\/>/true,/g;
    s/<false\/>/false,/g;

    s/<\/?plist[^>]*>//g;
    s/<!DOCTYPE[^>]*>//;
    s/<\?xml[^>]*>//;
    s/^\n+//s;

    s/\n},/\n};/gs;

    print "# $ARGV\n";
    print $_;
}
sub squote {
    my $txt=shift;
    $txt =~ s/['\\]/\\$&/g;
    $txt =~ s/\n/\\n/g;
    $txt =~ s/\r/\\r/g;
    $txt =~ s/\t/\\t/g;
    $txt =~ s/\0/\\0/g;
    return ($txt =~ /^[a-zA-Z_]\w*$/) ? $txt : "'$txt'";
}
sub dquote {
    my $txt=shift;
    $txt =~ s/["\\@]/\\$&/g;
    $txt =~ s/\n/\\n/g;
    $txt =~ s/\r/\\r/g;
    $txt =~ s/\t/\\t/g;
    $txt =~ s/\0/\\0/g;
    return "\"$txt\"";
}
sub unescape {
    my $txt=shift;
    $txt=~s/&lt;/</g;
    $txt=~s/&gt;/>/g;
    $txt=~s/&quot;/"/g;
    $txt=~s/&#(\d\w+);/chr(eval($1))/ge;
    $txt=~s/&amp;/&/g;
    return $txt;
}