File Coverage

blib/lib/Mac/Apps/MacPGP.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

#!perl -w
package Mac::Apps::MacPGP;
require 5.004;
use vars qw($VERSION $be @ISA @EXPORT);
use strict;
use Exporter;
use Carp;
use Mac::AppleEvents;
use Mac::Apps::Launch;
@ISA = qw(Exporter);
@EXPORT = ();
$VERSION = sprintf("%d.%02d", q$Revision: 1.20 $ =~ /(\d+)\.(\d+)/);
$be = '';
#=================================================================
# Stuff
#=================================================================
sub new {
	my $self = shift;
	&_MpgpLaunchApp;
	return bless{}, $self;
}
#-----------------------------------------------------------------
sub DESTROY {
	my $self = shift;
	&_MpgpFrontApp($self->{MpgpMainApp}) if ($self->{MpgpSwitchApps} && $self->{MpgpSwitchApps} == 1 && $self->{MpgpMainApp});
}
#-----------------------------------------------------------------
sub getresults {
	my($self,$res) = @_;
	$res = 'result' if (!$res);
	return $self->{results}->{$res};
}
#-----------------------------------------------------------------
sub getresultsall {
	my($self) = shift;
	my($results) = $self->{results};
	return %{$results};
}
#-----------------------------------------------------------------
sub switchapp {
	my($self,$do,$app) = @_;
	if (defined $do) {
		$self->{MpgpSwitchApps} = $do;
	}
	if ($app) {
		$self->{MpgpMainApp} = $app;
	}
	&_MpgpFrontApp('MPGP') if ($self->{MpgpSwitchApps} == 1);
	return 1;
}
#-----------------------------------------------------------------
sub quitpgp {
	my($be) = AEBuildAppleEvent('aevt','quit',typeApplSignature,'MPGP',0,0,'') || croak $^E;
	AESend($be, kAEWaitReply) || croak $^E;
	AEDisposeDesc $be;
	return 1;
}
#=================================================================
# Main subroutines
#=================================================================
sub encrypt {
	my(@p)	= @_;
	my($ev)	= &_checkType($p[1],'encr','ncrd','cncr');
	$be		= &_MpgpAeBuild($ev);
	my($ae);
	if (scalar(@{$p[2]}))
						{&_dObjData($p[2],'a')	}
	elsif ($p[2])
						{&_dObjData($p[2],'t')	}
	else				{&_MpgpError('m','dObj') unless ($ev eq 'ncrd')}
	if ($ev ne 'cncr') {
		if (scalar(@{$p[3]}))
						{&_recvData($p[3],'a')	}
		elsif ($p[3])
						{&_recvData($p[3],'t')	} else {&_MpgpError('m','recv')}}
	if ($p[3] && $ev eq 'cncr')
						{&_cpasData($p[3])		}
	if ($p[4])			{&_passData($p[4])		}
	if ($p[5])			{&_usidData($p[5])		}
	if ($p[6])			{&_signData($p[6],'e')	}
	if ($p[7])			{&_readData($p[7])		}
	if ($p[8])			{&_outpData($p[8])		} else {&_outpData('asci')}
	if (defined $p[9])	{&_latiData($p[9])		}
	if (defined $p[10])	{&_wrapData($p[10])		}
	if (defined $p[11])	{&_alnsData($p[11])		}
	if (defined $p[12] && (AEGetParamDesc($be,'wrap') !=0))
						{&_tabxData($p[12])		}
	if ($p[13])			{&_mdalData($p[13])		}
	if ($p[14] && $ev ne 'ncrd')
						{&_wsrcData($p[14])		}
	if ($p[15] && $ev eq 'cncr')
						{&_coptData($p[15])		}
	&_MpgpError('s','')
		if ((AEGetParamDesc($be,'sign') eq 'incl') &&
			(AEGetParamDesc($be,'copt') =~ /sdf/));
	return &_MpgpAeProcess($p[0]);
}
#-----------------------------------------------------------------
sub decrypt {
	my(@p)	= @_;
	my($ev)	= &_checkType($p[1],'decr','dcrd');
	$be		= &_MpgpAeBuild($ev);
	if (scalar(@{$p[2]}))
						{&_dObjData($p[2],'a')	}
	elsif ($p[2])
						{&_dObjData($p[2],'t')	}
	else				{&_MpgpError('m','dObj') unless ($ev eq 'dcrd')}
	if ($p[3])			{&_passData($p[3])		}
	if (defined $p[4])	{&_screData($p[4])		}
	if (defined $p[5])	{&_nsigData($p[5])		}
	if ($p[6])			{&_apl2Data($p[6])		}
	if ($p[7] && $ev eq 'decr')
						{&_recvData($p[7],'t')	}
	return &_MpgpAeProcess($p[0]);
}
#-----------------------------------------------------------------
sub sign {
	my(@p)	= @_;
	my($ev)	= &_checkType($p[1],'sign','sigd');
	$be		= &_MpgpAeBuild($ev);
	my($ae);
	if (scalar(@{$p[2]}))
						{&_dObjData($p[2],'a')	}
	elsif ($p[2])
						{&_dObjData($p[2],'t')	}
	else				{&_MpgpError('m','dObj') unless ($ev eq 'sigd')}
	if ($p[3])			{&_passData($p[3])		}
	if ($p[4])			{&_usidData($p[4])		}
	if ($p[5])			{&_signData($p[5],'s')	}
	if ($p[6])			{&_readData($p[6])		}
	if ($p[7])			{&_outpData($p[7])		} else {&_outpData('asci')}
	if (defined $p[8])	{&_latiData($p[8])		}
	if (defined $p[9])	{&_wrapData($p[9])		}
	if (defined $p[10])	{&_alnsData($p[10])		}
	if (defined $p[11] && (AEGetParamDesc($be,'wrap') !=0))
						{&_tabxData($p[11],$ae)	}
	if ($p[12])			{&_mdalData($p[12])		}
	if ($p[13])			{&_stfxData($p[13])		}
	return &_MpgpAeProcess($p[0]);
}
#-----------------------------------------------------------------
sub asciify {
	my(@p)	= @_;
	my($ev) = 'asci';
	$be		= &_MpgpAeBuild($ev);
	my($ae);
	if (scalar(@{$p[1]}))
						{&_dObjData($p[1],'a')	}
	elsif ($p[1])
						{&_dObjData($p[1],'t')	} else {&_MpgpError('m','dObj')}
	if ($p[2])			{&_readData($p[2])		}
	if (defined $p[3])	{&_latiData($p[3])		}
	if (defined $p[4])	{&_wrapData($p[4])		}
	if (defined $p[5])	{&_alnsData($p[5])		}
	if (defined $p[6] && (AEGetParamDesc($be,'wrap') !=0))
						{&_tabxData($p[6],$ae)	}
	return &_MpgpAeProcess($p[0]);
}
#-----------------------------------------------------------------
sub execute {
	my(@p)	= @_;
	my($ev) = 'exec';
	$be		= &_MpgpAeBuild($ev);
	my($ae);
	if ($p[1])			{&_dObjData($p[1],'t')	} else {&_MpgpError('m','dObj')}
	if ($p[2])			{&_passData($p[2])		}
	if (defined $p[3])	{&_latiData($p[3])		}
	if (defined $p[4])	{&_wrapData($p[4])		}
	if (defined $p[5])	{&_alnsData($p[5])		}
	if (defined $p[6] && (AEGetParamDesc($be,'wrap') !=0))
						{&_tabxData($p[6],$ae)	}
	if ($p[7])			{&_mdalData($p[7])		}
	return &_MpgpAeProcess($p[0]);
}
#-----------------------------------------------------------------
sub keyring {
	my(@p)	= @_;
	my($ev)	= &_checkType($p[1],'selk','ckey','crfy','remv','addk','fing');
	$be		= &_MpgpAeBuild($ev);
	if ($p[2])			{&_dObjData($p[2],'t')	} else {&_MpgpError('m','dObj')}
	if ($p[3])			{&_keyrData($p[3])		}
	if ($p[4] && $ev eq 'crfy')
						{&_usidData($p[4])		}
	return &_MpgpAeProcess($p[0]);
}
#-----------------------------------------------------------------
sub extract {
	my(@p)	= @_;
	my($ev) = 'extr';
	$be		= &_MpgpAeBuild($ev);
	if ($p[1])			{&_dObjData($p[1],'t')	} else {&_MpgpError('m','dObj')}
	if ($p[2])			{&_recvData($p[2],'t')	} else {&_MpgpError('m','recv')}
	if ($p[3])			{&_keyrData($p[3])		}
	if ($p[4])			{&_outpData($p[4])		} else {&_outpData('asci')}
	return &_MpgpAeProcess($p[0]);
}
#-----------------------------------------------------------------
sub generate {
	my(@p)	= @_;
	my($ev) = 'gene';
	$be		= &_MpgpAeBuild($ev);
	if ($p[1])			{&_dObjData($p[1],'t')	} else {&_MpgpError('m','dObj')}
	if ($p[2])			{&_lengData($p[2])		}
	if ($p[3])			{&_ebitData($p[3])		}
	return &_MpgpAeProcess($p[0]);
}
#-----------------------------------------------------------------
sub logfile {
	my(@p)	= @_;
	my($ev) = 'logf';
	$be		= &_MpgpAeBuild($ev);
	my($ae);
	if ($p[1])			{&_dObjData($p[1],'b')	} else {&_MpgpError('m','dObj')}
	if ($p[2])			{&_recvData($p[2],'t')	}
	return &_MpgpAeProcess($p[0]);
}
#-----------------------------------------------------------------
sub window {
	my(@p)	= @_;
	my($ev) = 'wind';
	$be		= &_MpgpAeBuild($ev);
	my($ae);
	if ($p[1])			{&_windData($p[1])		} else {&_MpgpError('m','dObj')}
	return &_MpgpAeProcess($p[0]);
}
#-----------------------------------------------------------------
sub create {
	my(@p)	= @_;
	my($ev) = 'crea';
	$be		= &_MpgpAeBuild($ev);
	my($ae);
	if ($p[1])			{&_dObjData($p[1],'t') } else {&_MpgpError('m','dObj')}
	return &_MpgpAeProcess($p[0]);
}
#-----------------------------------------------------------------
sub clip2file {
	my(@p)	= @_;
	my($ev) = 'sc2f';
	$be		= &_MpgpAeBuild($ev);
	my($ae);
	if ($p[1])			{&_dObjData($p[1],'t') } else {&_MpgpError('m','dObj')}
	return &_MpgpAeProcess($p[0]);
}
#-----------------------------------------------------------------
sub file2clip {
	my(@p)	= @_;
	my($ev) = 'f2sc';
	$be		= &_MpgpAeBuild($ev);
	my($ae);
	if ($p[1])			{&_dObjData($p[1],'t') } else {&_MpgpError('m','dObj')}
	return &_MpgpAeProcess($p[0]);
}
#-----------------------------------------------------------------
sub checksignresult {
	my(@p)	= @_;
	my($ev) = 'cksg';
	$be		= &_MpgpAeBuild($ev);
	return &_MpgpAeProcess($p[0]);
}
#-----------------------------------------------------------------
sub getlasterror {
	my(@p)	= @_;
	my($ev) = 'gler';
	$be		= &_MpgpAeBuild($ev);
	return &_MpgpAeProcess($p[0]);
}
#-----------------------------------------------------------------
sub getversion {
	my(@p)	= @_;
	my($ev) = 'gver';
	$be		= &_MpgpAeBuild($ev);
	return &_MpgpAeProcess($p[0]);
}
#=================================================================
# Check AE param ids
#=================================================================
sub _checkType {
	my($ev,@evs)  = @_;
	return $ev if (&_oneOf('evType',$ev,\@evs));
}
#=================================================================
# Process data into AE descriptors
#=================================================================
sub _dObjData {
	my($data,$type) = @_;
	if ($type eq 't') {
		&_MpgpBText($data,'----');
	} elsif ($type eq 'a') {
		&_MpgpBTextArray($data,'----');
	} elsif ($type eq 'b') {
		&_MpgpBBool($data,'----');
	}
}
#-----------------------------------------------------------------
sub _recvData {
	my($data,$type) = @_;
	if ($type eq 'a') {
		&_MpgpBTextArray($data,'recv');
	} elsif ($type eq 't') {
		&_MpgpBText($data,'recv');
	}
}
#-----------------------------------------------------------------
sub _passData {
	my($data) = @_;
	&_MpgpBText($data,'pass');
}
#-----------------------------------------------------------------
sub _cpasData {
	my($data) = @_;
	&_MpgpBText($data,'cpas');
}
#-----------------------------------------------------------------
sub _usidData {
	my($data) = @_;
	&_MpgpBText($data,'usid');
}
#-----------------------------------------------------------------
sub _apl2Data {
	my($data) = @_;
	&_MpgpBText($data,'apl2');
}
#-----------------------------------------------------------------
sub _keyrData {
	my($data) = @_;
	&_MpgpBText($data,'keyr');
}
#-----------------------------------------------------------------
sub _signData {
	my($data,$type) = @_;
	my(@datas);
	if ($type eq 'e') {
		@datas = qw(incl sepa omit);
	} elsif ($type eq 's') {
		@datas = qw(incl sepa clea);
	}
	&_MpgpBKeyw($data,'sign') if (&_oneOf('sign',$data,\@datas));
}
#-----------------------------------------------------------------
sub _readData {
	my($data) = @_;
	my(@datas) = qw(macb text norm);
	&_MpgpBKeyw($data,'read') if (&_oneOf('read',$data,\@datas));
}
#-----------------------------------------------------------------
sub _outpData {
	my($data) = @_;
	my(@datas) = qw(bina asci);
	&_MpgpBKeyw($data,'outp') if (&_oneOf('outp',$data,\@datas));
}
#-----------------------------------------------------------------
sub _windData {
	my($data) = @_;
	my(@datas) = qw(show hide);
	&_MpgpBKeyw($data,'----') if (&_oneOf('wind',$data,\@datas));
}
#-----------------------------------------------------------------
sub _coptData {
	my($data) = @_;
	my(@datas) = qw(sdf sdfb);
	&_MpgpBKeyw($data,'copt') if (&_oneOf('copt',$data,\@datas));
}
#-----------------------------------------------------------------
sub _mdalData {
	my($data) = @_;
	my(@datas) = qw(MD5 SHA1);
	&_MpgpBKeyw($data,'mdal') if (&_oneOf('mdal',$data,\@datas));
}
#-----------------------------------------------------------------
sub _wsrcData {
	my($data) = @_;
	&_MpgpBBool($data,'wsrc');
}
#-----------------------------------------------------------------
sub _latiData {
	my($data) = @_;
	&_MpgpBBool($data,'lati');
}
#-----------------------------------------------------------------
sub _screData {
	my($data) = @_;
	&_MpgpBBool($data,'scre');
}
#-----------------------------------------------------------------
sub _nsigData {
	my($data) = @_;
	&_MpgpBBool($data,'nsig');
}
#-----------------------------------------------------------------
sub _stfxData {
	my($data) = @_;
	&_MpgpBBool($data,'stfx');
}
#-----------------------------------------------------------------
sub _wrapData {
	my($data) = @_;
	my(@datas) = qw(30 100);
	&_MpgpBShort($data,'wrap') if (&_twixtOf('wrap',$data,\@datas));
}
#-----------------------------------------------------------------
sub _alnsData {
	my($data) = @_;
	my(@datas) = qw(0 1E+1000);
	&_MpgpBShort($data,'alns') if (&_twixtOf('alns',$data,\@datas));
}
#-----------------------------------------------------------------
sub _tabxData {
	my($data) = @_;
	my(@datas) = qw(0 9);
	&_MpgpBShort($data,'tabx') if (&_twixtOf('tabx',$data,\@datas));
}
#-----------------------------------------------------------------
sub _ebitData {
	my($data) = @_;
	my(@datas) = qw(0 1E+1000);
	&_MpgpBShort($data,'ebit') if (&_twixtOf('ebit',$data,\@datas));
}
#-----------------------------------------------------------------
sub _lengData {
	my($data) = @_;
	my(@datas);
	if ($data !~ /\D/) {
		@datas = qw(384 2048);
		&_MpgpBShort($data,'kbit') if (&_twixtOf('kbit',$data,\@datas));
	} else {
		@datas = qw(casu comm mili);
		&_MpgpBKeyw($data,'leng') if (&_oneOf('leng',$data,\@datas));
	}
}
#=================================================================
# Error checking of data
#=================================================================
sub _twixtOf {
	my($type,$one,$of) = @_;
	&_MpgpError('d',$type) unless
		(($one !~ /\D/ && $one >= $$of[0] && $one <= $$of[1]) || ($one == 0));
	return 1;
}
#-----------------------------------------------------------------
sub _oneOf {
	my($type,$one,$of,$yes) = @_;
	foreach (@{$of}) {
		$yes = 1 if ($one eq $_);
	}
	if (!$yes) {
		&_MpgpError('t',$type);
	}
	return 1;
}
#=================================================================
# Add AE descriptor records to event
#=================================================================
sub _MpgpBKeyw {
	my($data,$type) = @_;
	AEPutParamDesc($be,$type,(AEBuild($data)));
}
#-----------------------------------------------------------------
sub _MpgpBShort {
	my($data,$type) = @_;
	AEPutParamDesc($be,$type,(AEBuild($data)));
}
#-----------------------------------------------------------------
sub _MpgpBBool {
	my($data,$type) = @_;
	if ($data eq '1') {
		$data = 'true';
	} elsif ($data eq '0') {
		$data = 'fals';
	} else {
		&_MpgpError('b',$type);
	}
	AEPutParamDesc($be,$type,(AEBuild($data)));
}
#-----------------------------------------------------------------
sub _MpgpBText {
	my($data,$type) = @_;
	AEPutParamDesc($be,$type,(AEBuild('TEXT(@)',$data)));
}
#-----------------------------------------------------------------
sub _MpgpBTextArray {
	my($data,$type) = @_;
	my($ta) = '[';
	foreach (@{$data}) {
		$ta .= 'TEXT(@),';
	}
	$ta =~ s/,$/]/;
	AEPutParamDesc($be,$type,(AEBuild($ta,@{$data})));
}
#=================================================================
# Main processing
#=================================================================
sub _MpgpLaunchApp {
	my($app) = shift || 'MPGP';
	LaunchApps([$app],0);
}
#-----------------------------------------------------------------
sub _MpgpFrontApp {
	my($app) = @_;
	LaunchApps([$app],1);
}
#-----------------------------------------------------------------
sub _MpgpError {
	my($type,$info) = @_;
	if ($type eq 'm') {
		croak "Missing required element of type: $info.\n";
	} elsif ($type eq 'd') {
		croak "Value of $info does not fall within acceptable bounds.\n";
	} elsif ($type eq 't') {
		croak "Value of $info does not match acceptable parameters.\n";
	} elsif ($type eq 'b') {
		croak "Value of $info must be either 1 or 0 (boolean).\n";
	} elsif ($type eq 's') {
		croak "Cannot include signature in self-decrypting files.\n";
	} else {
		croak "Unknown error ($type, $info).\n";
	}
}
#-----------------------------------------------------------------
sub _MpgpAeBuild {
	my($ev,$st) = @_;
	$st = 'MPGP' if (!$st);
	my($be) = AEBuildAppleEvent($st,$ev,typeApplSignature,'MPGP',0,0,'') || croak $^E;
	return $be;
}
#-----------------------------------------------------------------
sub _MpgpAePrint {
	my($self,$rp) = @_;
	my(@ar,%ar,$ar,$at);
	@ar = ('----','errn','errs','outp');
	foreach $ar(@ar) {
		if ($at = AEGetParamDesc($rp,$ar)) {
			$ar{$ar} = AEPrint($at);
		}
	}
	if (exists $ar{'----'}) {
		$ar{'----'} =~ s/^Ò(.*)Ó$/$1/s;
		$ar{'result'} = $ar{'----'};
	}
	if ($ar{'errn'}) {
		$ar{'errs'} =~ s/^Ò(.*)Ó$/$1/ if (exists $ar{'errs'});
		carp "MacPGP error $ar{'errn'}: $ar{'errs'}\n";
	}
	if (exists $ar{'outp'}) {
		$ar{'outp'} =~ s/^\[alis\(\Ç(.*?)\È\)\]/$1/;
#		$ar{'outp'} = (pack("H*",$ar{'outp'}));
	}
	$self->{results} = \%ar;
	AEDisposeDesc $rp;
	return $ar{result};
}
#-----------------------------------------------------------------
sub _MpgpAeProcess {
	my($self) = shift;
	my($rp) = AESend($be, kAEWaitReply) || croak $^E;
	AEDisposeDesc $be;
	return &_MpgpAePrint($self,$rp);
}
#-----------------------------------------------------------------#
1;
__END__