File Coverage

blib/lib/Mac/AppleEvents/Simple.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

package Mac::AppleEvents::Simple;
require 5.004;
use strict;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION $SWITCH
	$CLASSREC $ENUMREC %AE_GET %DESCS $DESCCOUNT $WARN $DEBUG $REVISION);

use Carp;
use Exporter;
use Mac::AppleEvents 1.30;
use Mac::Apps::Launch 1.90;
use Mac::Processes 1.04;
use Mac::Files;
use Mac::Types;
use Mac::Errors qw(%MacErrors $MacError);
use Time::Epoch 'epoch2perl';

#-----------------------------------------------------------------

@ISA = qw(Exporter Mac::AppleEvents);
@EXPORT = qw(
	do_event build_event handle_event
	pack_ppc pack_eppc pack_eppc_x pack_psn pack_pid
);
@EXPORT_OK = (@EXPORT, @Mac::AppleEvents::EXPORT);
%EXPORT_TAGS = (all => [@EXPORT, @EXPORT_OK]);

$REVISION = '$Id: Simple.pm,v 1.26 2006/07/07 06:44:37 pudge Exp $';
$VERSION  = '1.18';
$DEBUG	||= 0;
$SWITCH ||= 0;
$WARN	||= 0;

# some users won't have Carp::cluck ...
sub cluck;
*cluck = *Carp::cluck{CODE} || sub { warn Carp::longmess @_ };

#-----------------------------------------------------------------
# Main public methods and functions
#-----------------------------------------------------------------

sub do_event {
	my $self = bless _construct(@_), __PACKAGE__;
	$self->_build_event and return $self->_warn;
	$self->_send_event  and return $self->_warn;
	$self->_sending     and return $self->_warn;
	$self;
}

#-----------------------------------------------------------------

sub build_event {
	my $self = bless _construct(@_), __PACKAGE__;
	$self->_build_event       and return $self->_warn;
#	$self->_print_desc('EVT') and return $self->_warn;
	$self;
}

#-----------------------------------------------------------------

sub handle_event {
	my($class, $event, $code, $sys) = @_;
	my $hash = $sys ? \%SysAppleEvent : \%AppleEvent;
	my $handler = bless [$hash, $class, $event],
		__PACKAGE__ . '::Handler';

	$hash->{$class, $event} = sub {
		my($evt, $rep, $key) = @_;
		# make 'em backward!
		my $obj = bless {
			REP => $evt,
			EVT => $rep,
			HANDLER => $handler
		}, __PACKAGE__;
		$code->($obj, split /$;/, $key);
		0;
	};

	return;
}

#-----------------------------------------------------------------

sub send_event {
	my $self = shift;
	$self->_send_event(@_) and return $self->_warn;
	$self->_sending        and return $self->_warn;
	$self;
}

#-----------------------------------------------------------------

sub type {
	my($self, $key) = @_;
	my($d, $desc);
	$d = ref $self eq __PACKAGE__ ? $self->{REP} : $self;
	return unless ref $d eq 'AEDesc';
	return unless
		defined($desc = AEGetParamDesc($d, $key || keyDirectObject));

	my $type = $desc->type;
	AEDisposeDesc($desc);
	return $type;
}

#-----------------------------------------------------------------

sub data {
	my($self, $key) = @_;
	my($d, $desc, $num, @ret);

	$d = ref $self eq __PACKAGE__ ? $self->{REP} : $self;
	return unless ref $d eq 'AEDesc';
	return unless
		defined($desc = AEGetParamDesc($d, $key || keyDirectObject));

	# special-case typeAERecord here, too?
	if ($num = AECountItems($desc)) {
		for (1 .. $num) {
			my $d = AEGetNthDesc($desc, $_);
			push @ret, $d;
		}
		return wantarray ? @ret : $ret[0];
	} else {
		return $desc;
	}
}

#-----------------------------------------------------------------

sub get {
	my($self, $key) = @_;
	my($d, $desc, $num);

	$d = ref $self eq __PACKAGE__ ? $self->{REP} : $self;
	return unless ref $d eq 'AEDesc';
	return unless
		defined($desc = AEGetParamDesc($d, $key || keyDirectObject));

	if ($num = AECountItems($desc)) {
		if ($desc->type eq typeAEList) {
			my @ret;
			for (1..$num) {
				push @ret, _getdata(AEGetNthDesc($desc, $_));
			}
			# if scalar context, return ref instead?
			AEDisposeDesc($desc);
			return wantarray ? @ret : $ret[0];

		} elsif ($desc->type eq typeAERecord) {
			my %ret;
			for (1..$num) {
				my @d = AEGetNthDesc($desc, $_);
				$ret{$d[1]} = _getdata($d[0]);
			}
			AEDisposeDesc($desc);
			# if scalar context, return ref instead?
			return %ret;
		}
	}
	return _getdata($desc);
}

#-----------------------------------------------------------------

sub pack_psn {
	my($psn) = @_;
	return pack 'll', 0, $psn;
}

#-----------------------------------------------------------------

sub pack_pid {
	my($pid) = @_;
	return pack 'l', $pid;
}

#-----------------------------------------------------------------

sub pack_eppc_x {
	my($name, $server, $uid, $pid, $user, $pass) = @_;

	my $info;
	$info = $user if defined $user;
	$info .= ':' . $pass if defined $user && defined $pass;

	my @query;
	push @query, uid => $uid if $uid;
	push @query, pid => $pid if $pid;

	require URI;
	my $uri = new URI;
	$uri->scheme('http');
	$uri->path($name);
	$uri->host($server);
	$uri->query_form(@query) if @query;
	$uri->userinfo($info) if defined $info;
	$uri =~ s/http/eppc/;

	return $uri;
}

#-----------------------------------------------------------------

sub pack_ppc  { _pack_ppc('ppc',  @_) }
sub pack_eppc { _pack_ppc('eppc', @_) }

sub _pack_ppc {
	my($type, $id, $name, $server, $zone) = @_;
	my %TargetID;

	$TargetID{sess} = ['l', 0];			# long sessionID
	$TargetID{name} = ['sca33sca33',		# PPCPortRec name
		0,						# ScriptCode nameScript
		length($name), $name,				# Str32Field name
		2,						# PPCPortKinds ppcByString
		length($id . 'ep01'), $id . 'ep01',		# Str32 portTypeStr
		# why ep01? dick karpinski suggests it might be
		# "Ethernet port 01", so maybe we need to find out
		# the port automatically ... ick.
	];

	if ($type eq 'ppc') {
		my $atype = 'PPCToolbox';
		$zone ||= '*';
		$TargetID{loca} = ['sca33ca33ca33',	# LocationNameRec location
			1,				# PPCLocationKind ppcNBPLocation
							# EntityName
			length($server), $server,		# Str32Field objStr
			length($atype), $atype,			# Str32Field typeStr
			length($zone), $zone,			# Str32Field zoneStr
		];
	} elsif ($type eq 'eppc') {
		$TargetID{loca} = ['ssssa*',		# LocationNameRec location
			3,				# PPCLocationKind
							#	  ppcXTIAddrLocation
							# PPCAddrRec xtiType
			0,					# UInt8 Reserved (0)
			2 + length($server),			# UInt8 xtiAddrLen
								# PPCXTIAddress xtiAddr
			42,						# PPCXTIAddressType
									#	  kDNSAddrType
			$server						# UInt8 fAddress[96]
		];
	} else {
		carp "Type $type not recognized\n";
	}

	my($format, @args, $targ);
	for (qw[sess name loca]) {
		my @foo = @{$TargetID{$_}};
		$format .= shift @foo;
		push @args, @foo;
	}
	$targ  = pack $format, @args;

	printf("> %s\n< %s\n\n", $targ, join("|", unpack $format, $targ))
		if $DEBUG > 1;
	return $targ;
}

#-----------------------------------------------------------------
# Private methods
#-----------------------------------------------------------------

sub _getdata {
	my($desc) = @_;
	my $type = $desc->type;
	my($ret, $keep);

	if ($type eq typeEnumerated && $ENUMREC && defined &$ENUMREC) {
		$ret = $ENUMREC->($desc->get);
	}

	if (!$ret && !exists $AE_GET{$type} && !exists $MacUnpack{$type} && defined &$CLASSREC) {
		if ($CLASSREC->($type)) {
			my $tmp = AECoerceDesc($desc, typeAERecord); # or die "Type [$type]: $MacError\n";
			if ($tmp) {
				AEDisposeDesc $desc;
				$desc = $tmp;
				$type = typeAERecord;
			}
		}
	}

	if (!$ret) {
		($ret, $keep) = exists($AE_GET{$type})
			? $AE_GET{$type}->($desc)
			: $desc->get;
	}

	AEDisposeDesc $desc unless $keep;
	return $ret;
}

#-----------------------------------------------------------------

sub _sending {
	my $self = shift;
#	$self->_print_desc('EVT');
#	$self->_print_desc('REP');
	$self->_event_error;
}

#-----------------------------------------------------------------

sub _construct {
	my $self = {};
	$self->{CLASS} = shift or croak 'Not enough parameters in AE build';
	$self->{EVNT} =  shift or croak 'Not enough parameters in AE build';
	$self->{APP} =   shift or croak 'Not enough parameters in AE build';

	if (ref $self->{APP} eq 'HASH') {
		for (keys %{$self->{APP}}) {
			$self->{ADDTYPE} = $_;
			$self->{ADDRESS} = $self->{APP}{$_};
			next;
		}
	} else {
		$self->{ADDTYPE} = typeApplSignature;
		$self->{ADDRESS} = $self->{APP};
	}

	$self->{DESC} = shift || '';
	$self->{PARAMS} = [@_];
	$self;
}

#-----------------------------------------------------------------

sub _print_desc {
	my $self = shift;
	my %what = (EVT => 'EVENT', REP => 'REPLY');
	$self->{$what{$_[0]}} = AEPrint $self->{$_[0]};
}

#-----------------------------------------------------------------

sub _build_event {
	my $self = shift;
	$self->{TRNS_ID} ||= kAnyTransactionID;
	$self->{EVT} = AEBuildAppleEvent(
		$self->{CLASS}, $self->{EVNT}, $self->{ADDTYPE},
		$self->{ADDRESS}, kAutoGenerateReturnID, $self->{TRNS_ID},
		$self->{DESC}, @{$self->{PARAMS}}
	);
	$self->{ERRNO} = $^E+0;
	$self->{ERROR} = $MacError;
	return $self->{ERRNO};
}

#-----------------------------------------------------------------

sub _send_event {
	my $self   = $_[0];
	my $launch = $_[4];

	if ($self->{ADDTYPE} eq typeApplSignature) {
		if (! IsRunning($self->{ADDRESS})) { # $launch
			LaunchApps($self->{ADDRESS}, $SWITCH) or
				warn "Can't launch '$self->{ADDRESS}': $MacError";
		} elsif ($SWITCH) {
			SetFront($self->{ADDRESS});
		}

	} elsif ($self->{ADDTYPE} eq typeApplicationBundleID) {
		my $path = $self->{PATH} || LSFindApplicationForInfo('', $self->{ADDRESS});
		if (! IsRunning($path, 1)) { # $launch
			LaunchSpecs($path, $SWITCH) or
				warn "Can't launch '$self->{ADDRESS}': $MacError";
		} elsif ($SWITCH) {
			SetFront($path, 1);
		}
	}

	$self->{R} = defined $_[1] ? $_[1] : $self->{GETREPLY} || kAEWaitReply;
	$self->{P} = defined $_[2] ? $_[2] : $self->{PRIORITY} || kAENormalPriority;
	$self->{T} = defined $_[3] ? $_[3] : $self->{TIMEOUT}  || kNoTimeOut;

	$self->{REP} = AESend(@{$self}{'EVT', 'R', 'P', 'T'});
	$self->{ERRNO} = $^E+0;
	$self->{ERROR} = $MacError;

#	if (!$launch && $self->{ERRNO} == -600) { #$MacErrors{connectionInvalid}->number) {
#		$self->_send_event(@_[1..3], 1);
#	}

	return $self->{ERRNO};
}

#-----------------------------------------------------------------

sub _event_error {
	my($self) = @_;
	my($event, $error);

	delete $self->{ERRNO};
	$event = $self->{REP};
	return unless $event;

	{
		local $^E;
		if (my $errn = AEGetParamDesc($event, keyErrorNumber)) {
			$self->{ERRNO} = $errn->get;
			AEDisposeDesc($errn);
		}

		if (my $errs = AEGetParamDesc($event, keyErrorString)) {
			$self->{ERROR} = $errs->get;
			AEDisposeDesc($errs);
		}
	}

	$self->{ERRNO} ||= $^E+0;
	$self->{ERROR} ||= $MacError;
	return $self->{ERRNO};
}

#-----------------------------------------------------------------

sub _warn {
	my $self = $_[0];
	if ($WARN) {
		my $warn = $WARN > 1 ? \&cluck : \&carp;
		if ($self->{ERROR}) {
			$warn->($self->{ERROR});
		} elsif ($self->{ERRNO}) {
			local $^E = $self->{ERRNO};
			$self->{ERROR} = $MacError;
			$warn->("Error $self->{ERRNO}: $self->{ERROR}");
		}
	}
	$self;
}

#-----------------------------------------------------------------

sub Mac::AppleEvents::Simple::Handler::DESTROY {
	my $self = shift;
	delete $self->[0]{$self->[1], $self->[2]};
}

#-----------------------------------------------------------------

DESTROY {
	my $self = shift;
	local $^E;	# save $^E
	unless ($self->{HANDLER}) {
		AEDisposeDesc $self->{EVT} if $self->{EVT};
		AEDisposeDesc $self->{REP} if $self->{REP};
	}
}

#-----------------------------------------------------------------

END {
	foreach my $desc (keys %DESCS) {
		print "Destroying $desc\n" if $DEBUG;
		if ($desc) {
			eval { print "\t", AEPrint($DESCS{$desc}), "\n" } if $DEBUG;
			AEDisposeDesc $DESCS{$desc} or warn "Can't dispose $desc: $MacError";
		}
	}
}

#-----------------------------------------------------------------

BEGIN {
	%AE_GET = (
		typeComp()			=> sub {
			return _get_coerce($_[0], typeFloat);
		},

		typeAlias()			=> sub {
			my $alis = $_[0]->data;
			my $return = ResolveAlias($alis) or die "Can't resolve alias: $MacError";
			$alis->dispose;
			return $return;
		},

		typeObjectSpecifier()		=> sub {
			$DESCS{ $_[0] } = $_[0];
			return($_[0], 1);
		},

		typeAEList()			=> sub {
			my $list = $_[0];
			my @data;
			for (1 .. AECountItems($list)) {
				my $d = AEGetNthDesc($list, $_) or die "Can't get desc: $MacError";
				push @data, _getdata($d);
			}
			return \@data;
		},

		typeAERecord()			=> sub {
			my $reco = $_[0];
			my %data;
			for (1 .. AECountItems($reco)) {
				my @d = AEGetNthDesc($reco, $_) or die "Can't get desc: $MacError";
				$data{$d[1]} = _getdata($d[0]);
			}
			return \%data;
		},

		typeProcessSerialNumber() 	=> sub {
			my $handle = $_[0]->data;
			my $num = $handle->get;
			$handle->dispose;
			my $psn = join '', unpack 'LL', $num;
			$psn =~ s/^0+//;
			return $psn;
		},

		typeLongDateTime() 		=> sub {
			my $handle = $_[0]->data;
			my $num = $handle->get;
			$handle->dispose;
			# typeLongDateTime is 64 bits, and the grep tosses out
			# the high bits, which will be good for as long
			# as the Unix 32-bit epoch lasts, which is good
			# enoguh for now; but this is not 64-bit safe, at all;
			# for that, we will use unpack 'Q' probably
			my($ldt) = grep $_, unpack 'LL', $num;
			return $^O eq 'MacOS' ? $ldt : epoch2perl($ldt, 'macos');
		},

		typeStyledText()		=> sub {
			return _get_coerce($_[0], typeChar);
		},

		typeQDPoint()			=> sub {
			my $handle = $_[0]->data;
			my $point = $handle->get;
			$handle->dispose;
			return [reverse unpack "s4s4", $point];
		},

		typeQDRectangle()		=> sub {
			return [ ($_[0]->get)[1,0,3,2] ];
		},

	);

	%AE_GET = (%AE_GET,
		typeUnicodeText()	=> $AE_GET{typeStyledText()},
		typeIntlText()		=> $AE_GET{typeStyledText()},
		typeAEText()		=> $AE_GET{typeStyledText()},
#		  UREC => sub {
#			  $AE_GET{typeAERecord()}->(AECoerceDesc(shift, typeAERecord));
#		  },
	);

}

sub _get_coerce {
	my $data = AECoerceDesc(@_) or die $^E+0;
	return $data->get;
}

1;

__END__