use strict;
use warnings;

use Win32::TieRegistry (Delimiter => '/');
use Encode;
use Data::Dumper;

my %r = (
  PSTGuidLocation => '01023d00',
  MasterConfig => '01023d0e',
  PSTCheckFile => '00033009',
  PSTFile => '001f6700',
  PSTFile1 => '001e6700',
  keyMaster => '9207f3e0a3b11019908b08002b2a56c2',
  ProfilesRoot => 'CUser/Software/Microsoft/Windows NT/CurrentVersion/
+Windows Messaging Subsystem/Profiles/',
  DefaultProfileString => '/DefaultProfile',
);

my $MessagingRoot = $Registry->{$r{ProfilesRoot}} # points to the Prof
+iles reg path of the current user
  or die "Windows Messaging not installed here!?\n";

my $DefaultProfileName = $MessagingRoot->{$r{DefaultProfileString}}
  or die "There are no messaging profiles for this user on this machin
+e.\n";


my %Out = ("DefaultProfile" => $DefaultProfileName, Profiles => {});

my @Profiles = grep {s/\/$//} keys %{$MessagingRoot};

for my $profileName (@Profiles) {
  $Out{Profiles}{$profileName} = [ GetPSTsForProfile($profileName) ];
}

print Dumper(\%Out);

sub GetPSTsForProfile {
  my $profileName = shift;
  my $regProfile = $MessagingRoot->{"$profileName/"};

  my $strValue = $MessagingRoot->{"$profileName/$r{keyMaster}//$r{Mast
+erConfig}"};
  my $fmt = '%02x' x 16;
  my @PSTFileNames;
  for my $strPSTGuid (map {sprintf $fmt, unpack('C16', $_)} $strValue 
+=~ /.{16}/g) {
    my $PSTGuid2 = PSTlocation($regProfile->{"$strPSTGuid/"}) or next;
    push @PSTFileNames, PSTFileName($regProfile->{$PSTGuid2})
      if IsAPST($regProfile->{"$strPSTGuid/"});
  }
  return @PSTFileNames;
}

sub IsAPST {
  my $PSTGuid = shift or return;
  my $PSTGuildValue = $PSTGuid->{"/$r{PSTCheckFile}"}
    or return;
  unpack('L', $PSTGuildValue) == 0x20;
} 

sub PSTlocation {
  my $PSTGuid = shift or return;
  my $PSTGuildValue = $PSTGuid->{"/$r{PSTGuidLocation}"}
    or return;
  my $len = length($PSTGuildValue);
  my @PSTGuildValue = unpack("C$len",$PSTGuildValue);
  my $fmt = '%02x' x $len;
  sprintf($fmt, @PSTGuildValue);
}

sub PSTFileName {
  my $PSTGuid = shift or return;
  my $PSTName = $PSTGuid->{$r{PSTFile}};
  defined $PSTName ? decode('UCS2-LE', $PSTName) : $PSTGuid->{$r{PSTFi
+le1}};
}
[download]