File Coverage

blib/lib/Mac/OSA/Simple.pm

Criterion	Covered	Total	%
statement	16	18	88.8
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	22	24	91.6

package Mac::OSA::Simple;

use strict;
use vars qw(
	$VERSION $REVISION @ISA
	@EXPORT @EXPORT_OK %EXPORT_TAGS
	%ScriptComponents
);

use Carp;
use Exporter;

use File::Basename;
use MacPerl ();
use Mac::AppleEvents::Simple ':all';
use Mac::Components;
use Mac::Memory;
use Mac::OSA 1.03;
use Mac::Processes;
use Mac::Resources 1.03;

@ISA = qw(Exporter);
@EXPORT = qw(
	frontier applescript osa_script
	compile_frontier compile_applescript compile_osa_script
	load_osa_script %ScriptComponents
);
@EXPORT_OK = @Mac::OSA::EXPORT;
%EXPORT_TAGS = (all => [@EXPORT, @EXPORT_OK]);

$REVISION = '$Id: Simple.pm,v 1.8 2003/11/09 18:38:21 pudge Exp $';
$VERSION = '1.09';

tie %ScriptComponents, 'Mac::OSA::Simple::Components';

sub frontier            { _doscript('LAND', $_[0])          }
sub applescript         { _doscript('ascr', $_[0])          }
sub osa_script          { _doscript(@_[0, 1])               }

sub compile_frontier    { _compile_script('LAND', $_[0])    }
sub compile_applescript { _compile_script('ascr', $_[0])    }
sub compile_osa_script  { _compile_script(@_[0, 1])         }

sub load_osa_script     { _load_script(@_[0, 1, 2])         }

sub execute {
	my($self) = @_;
	my $value = my $return = '';

	$value = OSAExecute($self->{COMP}, $self->{ID}, 0, 0)
		or _mydie() && return;

	if ($value) {
		$return = OSADisplay($self->{COMP}, $value, typeChar, 0)
			or _mydie() && return;
		OSADispose($self->{COMP}, $value);
	}

	$self->{RETURN} = $return && $return->isa('AEDesc')
        	? $return->get : 1;

	AEDisposeDesc($return) if $return;

	return $self->{RETURN};
}

{ my $target; # define only once
sub call {
	my($self, $cid, $eid, $args, $mode) = @_;
	$mode = kOSAModeNull unless defined $mode;

	$target ||= { typeProcessSerialNumber() => kCurrentProcess() };

	my $format;
	if (ref($args) eq 'ARRAY') { # no record support yet
		$format = '[';
		$format .= join(', ', map { 'TEXT(@)' } 1 .. @$args);
		$format .= ']';
	} elsif (! ref($args)) {
		$format = 'TEXT(@)';
		$args = [ $args ];
	} else {
		carp "Only scalars and lists supported in call()";
	}

	my $event = build_event($cid, $eid, $target, "'----':$format", @$args);

	$event->{REP} = OSADoEvent(
		$self->{COMP}, $event->{EVT}, $self->{ID}, $mode
	) or _mydie() && return;

	return $event->get;
}
}

sub dispose {
	my($self) = @_;

	if ($self->{ID} && $self->{COMP}) {
		OSADispose($self->{COMP}, $self->{ID});
		delete $self->{ID};
		delete $self->{COMP};
	}

	if ($self->{SCRIPT}) {
		AEDisposeDesc($self->{SCRIPT});
		delete $self->{SCRIPT};
	}

	return 1;
}

sub save {
	my($self, $file, $resid, $name) = @_;

	my $scpt = $self->compiled or _mydie() && return;
	$self->{FILETYPE} ||= $^O eq 'MacOS' ? 'rsrc' : 'data';

	my $res;
	if (($self->{FILETYPE} && $self->{FILETYPE} eq 'rsrc') || (!$self->{FILETYPE} && $^O eq 'MacOS')) {
		$resid = defined($resid) ? $resid : ($self->{RESID} || 128);
		$name  = defined($name)  ? $name  : 'MacPerl Script';

		unless ($res = FSpOpenResFile($file, 0)) {
			FSpCreateResFile($file, 'ToyS', 'osas', 0) or _mydie() && return;
			$res = FSpOpenResFile($file, 0) or _mydie() && return;
		}

		my $foo = Get1Resource(kOSAScriptResourceType, $resid);
		if (defined $foo) {
			RemoveResource($foo) or _mydie() && return;
		}

		AddResource($scpt, kOSAScriptResourceType, $resid, $name)
			or _mydie() && return;

		UpdateResFile($res) or _mydie() && return;
		CloseResFile($res);

	} else {
		local $\;
		open my $fh, '>', $file;
		print $fh $scpt->get;
		close $fh;
		MacPerl::SetFileInfo('ToyS', 'osas', $file);
	}

	return 1;
}

sub source {
	my($self, $source, $text) = @_;

	$source = OSAGetSource($self->{COMP}, $self->{ID}, typeChar)
		or _mydie() && return;

	$self->{SOURCE} = $source && $source->isa('AEDesc')
        	? $source->get : '';

	AEDisposeDesc($source);

	$self->{SOURCE} =~ s/\015/\n/g unless $^O eq 'MacOS';
	$self->{SOURCE};
}

sub compiled {
	my($self, $script) = @_;

	$script = OSAStore($self->{COMP}, $self->{ID},
		typeOSAGenericStorage, 0)
		or _mydie() && return;

	push @{$self->{AEDESC}}, $script;

	return $script->data;
}

sub _doscript {
	my($c, $text) = @_;

	my $self = _compile_script($c, $text) or _mydie() && return;
	my $return = $self->execute;
	_mydie() && return unless defined $return;
	$self->dispose;

	return $return;
}

sub _load_script {
	my($scpt, $resid, $xtra) = @_;

	my $c = kOSAGenericScriptingComponentSubtype;
	my $self = bless {
		COMP => $ScriptComponents{$c},
		TYPE => $c
	}, __PACKAGE__;

	my $res;
	if (!ref $scpt) {
		# we used to support three-arg format; use third arg if supplied
		$resid = defined($xtra) ? $xtra
			: defined($resid) && $resid != 1 ? $resid
			: 128;
		my $file = $scpt;
		undef $scpt;

		if ($^O eq 'MacOS') {
			$res = FSpOpenResFile($file, 0) or _mydie() && return;
			$scpt = Get1Resource(kOSAScriptResourceType, $resid)
				or _mydie() && return;
		} else {
			$res = FSpOpenResFile($file, 0);
			$scpt = Get1Resource(kOSAScriptResourceType, $resid) if $res;

			if (!$scpt) {
				open my $fh, '<', $file or _mydie() && return;
				$scpt = new Handle do {
					local $/;
					<$fh>;
				};
			}
		}

		if ($res) {
			$self->{FILETYPE} = 'rsrc';
			$self->{RESID}    = $resid;
		} else {
			$self->{FILETYPE} = 'data';
			$self->{RESID}    = undef;
		}
	}

	my $desc = AECreateDesc(typeOSAGenericStorage, $scpt->get)
		or _mydie() && return;

	$self->{ID} = OSALoad($self->{COMP}, $desc, 0)
		or _mydie() && return;

	AEDisposeDesc($desc) if $desc;
	CloseResFile($res) if $res;

	return $self;
}

sub _compile_script {
	my($c, $text) = @_;

	my $comp = $ScriptComponents{$c} or return;

	my $self = bless {
		COMP   => $comp,
        	SOURCE => $text,
        	TYPE   => $c
        }, __PACKAGE__;

	return $self->_compile;
}

sub _compile {
	my($self) = @_;

	$self->{SCRIPT} = AECreateDesc(typeChar, $self->{SOURCE})
		or _mydie() && return;

	$self->{ID} = OSACompile($self->{COMP}, $self->{SCRIPT}, kOSAModeCompileIntoContext)
		or _mydie() && return;

	return $self;
}

sub _mydie {
	# maybe do something here some day
	1;
}

sub DESTROY {
	my($self) = @_;

	if (exists($self->{ID}) || exists($self->{SCRIPT})) {
		$self->dispose;
	}

	if ($self->{AEDESC}) {
		for (@{$self->{AEDESC}}) {
			AEDisposeDesc($_) if $_;
		}
	}

	undef $self;
}

END {
	foreach my $comp (keys %ScriptComponents) {
		CloseComponent($ScriptComponents{$comp});
	}
}

package Mac::OSA::Simple::Components;

BEGIN {
	use Carp;
	use Tie::Hash ();
	use Mac::Components;
	use Mac::OSA;
	use vars qw(@ISA);
	@ISA = qw(Tie::StdHash);
}

# { # if we don't do this, we fail if we fork ... weird
# 	my $x = 0;
# 	1 while ($x = FindNextComponent($x, kOSAComponentType));
# }
#
# sub FETCH {
# 	my($self, $comp) = @_;
# 	if ($self->{pid}) {
# 		if ($self->{pid} != $$) {
# 			delete @{$self}{keys %$self};
# 		}
# 	} else {
# 		$self->{pid} = $$;
# 	}

sub FETCH {
	my($self, $comp) = @_;

	my $c = $comp;
	if ($comp eq kOSAGenericScriptingComponentSubtype) {
		$c = 0;
		$c++ while exists $self->{$c};  # get unique key
	}

	if (!$self->{$c}) {
		my $comp = OpenDefaultComponent(kOSAComponentType, $comp)
			or Mac::OSA::Simple::_mydie() && return;
		$self->{$c} = $comp;
	}
	$self->{$c};
}

package Mac::OSA::Simple;  # odd "fix" for AutoSplit

1;

__END__