PERFORCE change 12326 for review
[email protected] (Chris Nandor) Wed, 3 Oct 2001 17:08:16 -0400
| Newsgroups | perl.perl5.changes.mac |
|---|---|
| Message-ID | <p05100302b7e12e6846fa@[10.0.1.177]> |
Change 12326 by pudge@pudge-mobile on 2001/10/03 19:08:28
Add in new macos/ modules, fix up BuildTools and Makefile.
Affected files ...
... //depot/maint-5.6/macperl/macos/Makefile.mk#8 edit
... //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/MD5.pm#1 add
... //depot/maint-5.6/macperl/macos/bundled_lib/t/MD5/md5.t#1 add
... //depot/maint-5.6/macperl/macos/lib/Mac/AETE/App.pm#1 add
... //depot/maint-5.6/macperl/macos/lib/Mac/AETE/Dialect.pm#1 add
... //depot/maint-5.6/macperl/macos/lib/Mac/AETE/Format/Converter.pm#1 add
... //depot/maint-5.6/macperl/macos/lib/Mac/AETE/Format/Dictionary.pm#1 add
... //depot/maint-5.6/macperl/macos/lib/Mac/AETE/Format/Glue.pm#1 add
... //depot/maint-5.6/macperl/macos/lib/Mac/AETE/Parser.pm#1 add
... //depot/maint-5.6/macperl/macos/lib/Mac/BuildTools.pm#2 edit
... //depot/maint-5.6/macperl/macos/lib/Mac/Glue.pm#1 add
... //depot/maint-5.6/macperl/macos/lib/Mac/OSA/Simple.pm#1 add
... //depot/maint-5.6/macperl/macos/lib/Mac/Toolbox.pod#1 add
Differences ...
==== //depot/maint-5.6/macperl/macos/Makefile.mk#8 (text) ====
Index: perl/macos/Makefile.mk
--- perl/macos/Makefile.mk.~1~ Wed Oct 3 13:15:05 2001
+++ perl/macos/Makefile.mk Wed Oct 3 13:15:05 2001
@@ -125,11 +125,16 @@
public = perl translators sitelib_install
Dynamic_Ext_Mac = Mac
Dynamic_Ext_Std =
-Dynamic_Ext_Xtr =
+Dynamic_Ext_Xtr =
+# this should be rewritten some, eh?
Static_Lib_Mac = \
ExtUtils:MM_MacOS ExtUtils:Miniperl Config Errno \
- Mac:Hooks Mac:Pane Mac::LowMem \
- Mac:AppleEvents:Simple Mac:BuildTools Mac:Apps:Launch
+ Mac:Hooks Mac:Pane Mac:LowMem \
+ Mac:AppleEvents:Simple Mac:OSA:Simple \
+ Mac:BuildTools Mac:Apps:Launch Mac:Toolbox \
+ Mac:AETE:App Mac:AETE:Dialect Mac:AETE:Parser \
+ Mac:AETE:Format:Converter Mac:AETE:Format:Dictionary \
+ Mac:AETE:Format:Glue Mac:Glue
########
# sync all extensions with both config.sh and macperl/Makefile.mk!
@@ -254,7 +259,7 @@
Directory :lib:
$(MACPERL_SRC)InstallBLIB "" Â
"::perl -I: -I:::lib: -e 'use File::Path; mkpath(\@ARGV, 1);'" Â
- $(Static_Lib_Mac:^":":+".pm")
+ $(Static_Lib_Mac:^":":+".pm") $(Static_Lib_Mac:^":":+".pod")
$(MACPERL_SRC)PerlInstall -l :::lib:
Directory ::bundled_lib:
$(MACPERL_SRC)PerlInstall -l :::lib:
==== //depot/maint-5.6/macperl/macos/lib/Mac/BuildTools.pm#2 (text) ====
Index: perl/macos/lib/Mac/BuildTools.pm
--- perl/macos/lib/Mac/BuildTools.pm.~1~ Wed Oct 3 13:15:05 2001
+++ perl/macos/lib/Mac/BuildTools.pm Wed Oct 3 13:15:05 2001
@@ -1,6 +1,7 @@
package Mac::BuildTools;
use AutoSplit;
+use Cwd;
use File::Copy;
use File::Find;
use File::Path;
@@ -13,195 +14,207 @@
# ExtUtils::MM_MacOS
sub make {
- my($self, $make_data, $name, $prefix, %copy, $file, @files, %mkpath, $cwd);
- $self = shift;
- $self->{'make'} = 'YES';
- $cwd = cwd();
+ my($self, $make_data, $name, $prefix, %copy, $file, @files, %mkpath, $cwd);
+ $self = shift;
+ $self->{'make'} = 'YES';
+ $cwd = cwd();
+
+ undef $@;
+ unless (eval { do ":Makefile.PL" }) {
+ warn "Can't do :Makefile.PL in $cwd\n";
+ }
+ warn $@ if $@;
- undef $@;
- unless (eval { do ":Makefile.PL" }) {
- warn "Can't do :Makefile.PL in $cwd\n";
- }
- warn $@ if $@;
+ $make_data = $ExtUtils::MM_MacOS::make_data{$cwd}
+ or die "No $cwd package data";
- $make_data = $ExtUtils::MM_MacOS::make_data{$cwd}
- or die "No $cwd package data";
+ @files = ((sort keys %{$make_data->{PM}}),
+ (sort keys %{$make_data->{XS}}));
- @files = ((sort keys %{$make_data->{PM}}),
- (sort keys %{$make_data->{XS}}));
-
- # taken from InstallBLIB
- $name = $make_data->{NAME};
- if (($prefix) = $name =~ /(.*::)/) {
- $prefix =~ s/::/:/g;
- }
+ # taken from InstallBLIB
+ $name = $make_data->{NAME};
+ if (($prefix) = $name =~ /(.*::)/) {
+ $prefix =~ s/::/:/g;
+ }
+ $prefix ||= "";
- FILE:
- for $file (@files) {
- $file = ":$file" unless $file =~ /^:/;
+ FILE:
+ for $file (@files) {
+ $file = ":$file" unless $file =~ /^:/;
-# this doesn't seem to be right: if something is in :lib:,
-# should we assume it already has the right prefxies?
-# (my $new = $file) =~ s|^:(lib:)?|:blib:lib:$prefix|;
- (my $new = $file) =~ s/^:(lib:|$prefix)?/':blib:lib:' .
- ($1 eq 'lib:' ? '' : $prefix)/e;
+# this doesn't seem to be right: if something is in :lib:,
+# should we assume it already has the right prefxies?
+# (my $new = $file) =~ s|^:(lib:)?|:blib:lib:$prefix|;
+ (my $new = $file) =~ s/^:(lib:|$prefix)?/':blib:lib:' .
+ ($1 && $1 eq 'lib:' ? '' : $prefix)/e;
- XSCHECK: {
- if ($file =~ /\.xs$/) {
- open(F, $file) || die;
- while (<F>) {
- last XSCHECK if /^=/;
- }
- print STDERR "Skipping $file, which doesn't contain any pod.\n";
- next FILE;
- }
- }
- $copy{$file} = $new;
- $new =~ /^(.*:)/;
- $mkpath{$1} = 1;
- }
- mkpath([sort keys %mkpath], 1);
+ XSCHECK: {
+ if ($file =~ /\.xs$/) {
+ open(F, $file) || die;
+ while (<F>) {
+ last XSCHECK if /^=/;
+ }
+ print STDERR "Skipping $file, which doesn't contain any pod.\n";
+ next FILE;
+ }
+ }
+ $copy{$file} = $new;
+ $new =~ /^(.*:)/;
+ $mkpath{$1} = 1;
+ }
+ mkpath([sort keys %mkpath], 1);
- foreach my $file (keys %copy) {
- print "copying $file -> $copy{$file}\n";
- copy($file, $copy{$file});
- }
+ foreach my $file (keys %copy) {
+ print "copying $file -> $copy{$file}\n";
+ copy($file, $copy{$file});
+ }
}
sub make_test {
- my $self = shift;
- $self->{'make_test'} = 'YES';
+ my $self = shift;
+ $self->{'make_test'} = 'YES';
}
sub make_clean {}
sub make_install {
- # taken from PerlInstall
- my(%dirs, $dir, $d);
- $dirs{lib} = "$ENV{MACPERL}site_perl";
- chomp($dir = `pwd`);
+ # taken from PerlInstall
+ my(%dirs, $dir, $d);
+ $dirs{lib} = "$ENV{MACPERL}site_perl";
+ chomp($dir = `pwd`);
+
+ $dir .= ":" unless ($dir =~ /:$/);
+ $dir .= "blib";
+
+ my($fromdir, $todir);
+ my $make_copyit = sub {
+ local($_) = $_;
+
+ my($newdir,$auto,$name) = ($File::Find::dir,
+ $File::Find::dir, $File::Find::name);
+
+ $newdir =~ s/\Q$fromdir\E/$todir/;
+ $auto =~ s/.*\Q$fromdir\E.*$/$todir:auto/;
+ $name =~ s/.*\Q$fromdir\E//;
+ return if -d $_;
+ $newdir =~ s/:$//;
+
+ printf(" %-20s -> %s\n", $name, $newdir);
+ mkpath($newdir, 1);
+
+ if (!copy($_, "$newdir:$_")) {
+ die $^E unless -e "$newdir:$_";
+ printf(" Moving %-20s -> %s\nDelete old file manually\n",
+ "$newdir:$_", "$newdir:$_ old");
+ move "$newdir:$_", "$newdir:$_ old";
+ copy($_, "$newdir:$_") or die $^E;
+ }
- $dir .= ":" unless ($dir =~ /:$/);
- $dir .= "blib";
+ autosplit("$newdir:$_", $auto, 0, 1, 0) if /\.pm$/;
+ };
- my($fromdir, $todir);
- my $make_copyit = sub {
- local($_) = $_;
- my($newdir,$auto,$name) = ($File::Find::dir,
- $File::Find::dir, $File::Find::name);
- $newdir =~ s/\Q$fromdir\E/$todir/;
- $auto =~ s/.*\Q$fromdir\E.*$/$todir:auto/;
- $name =~ s/.*\Q$fromdir\E//;
- return if -d $_;
- $newdir =~ s/:$//;
- printf(" %-20s -> %s\n", $name, $newdir);
- mkpath($newdir, 1);
- if (!copy($_, "$newdir:$_")) {
- die $^E unless -e "$newdir:$_";
- printf(" Moving %-20s -> %s\nDelete old file manually\n",
- "$newdir:$_", "$newdir:$_ old");
- move "$newdir:$_", "$newdir:$_ old";
- copy($_, "$newdir:$_") or die $^E;
+ opendir(DIR, $dir);
+ while (defined($d = readdir(DIR))) {
+ next unless -d "$dir:$d";
+ $fromdir = "$dir:$d";
+ $todir = $dirs{$d};
+ print " $fromdir\n";
+ find($make_copyit, $fromdir);
}
- autosplit("$newdir:$_", $auto, 0, 1, 0) if /\.pm$/;
- };
+ closedir(DIR);
- opendir(DIR, $dir);
- while (defined($d = readdir(DIR))) {
- next unless -d "$dir:$d";
- $fromdir = "$dir:$d";
- $todir = $dirs{$d};
- print " $fromdir\n";
- find($make_copyit, $fromdir);
- }
- closedir(DIR);
-
- $self->{'make_install'} = 'YES';
+ $self->{'make_install'} = 'YES';
}
sub convert_files {
- require Mac::Conversions;
- require Mac::InternetConfig;
- Mac::InternetConfig->import;
+ require Mac::Conversions;
+ require Mac::InternetConfig;
+ Mac::InternetConfig->import;
+
+ my @def = (GetICHelper('editor') || 'ttxt', 'TEXT');
+
+ my($files, $verbose) = @_;
+ my $conv = Mac::Conversions->new(Remove => 1);
+ foreach my $file (@$files) {
+ $file = ':' . Archive::Tar::_munge_file($file);
+ if (-e $file) {
+ chmod 0666, $file or warn "$file: $!\n";
+ }
+
+ my @info;
+ if (ref(my $map = $InternetConfigMap{$file}) eq 'ICMapEntry') {
+ @info = ($map->file_creator, $map->file_type);
+ }
+ @info = @def unless $info[0] && $info[1];
+ MacPerl::SetFileInfo(@info, $file);
+
+ if (! -e $file) {
+ print " Can't find '$file'\n";
+ } elsif (-T _) {
+ chmod 0666, $file or die $!;
+ local(*FILE, $/);
- my @def = (GetICHelper('editor') || 'ttxt', 'TEXT');
+ open(FILE, "< $file\0") or die $!;
+ my $text = <FILE>;
+ next unless $text;
+ $text =~ s/\015?\012/\n/g;
+ close(FILE);
- my($files, $verbose) = @_;
- my $conv = Mac::Conversions->new(Remove => 1);
- foreach my $file (@$files) {
- $file = ':' . Archive::Tar::_munge_file($file);
- if (-e $file) {
- chmod 0666, $file or warn "$file: $!\n";
- }
+ open(FILE, "> $file\0") or die $!;
+ print FILE $text;
+ close(FILE);
- my @info;
- if (ref(my $map = $InternetConfigMap{$file}) eq 'ICMapEntry') {
- @info = ($map->file_creator, $map->file_type);
- }
- @info = @def unless $info[0] && $info[1];
- MacPerl::SetFileInfo(@info, $file);
+ print " LF->CR translate $file\n" if $verbose;
- if (! -e $file) {
- print " Can't find '$file'\n";
- } elsif (-T _) {
- chmod 0666, $file or die $!;
- local(*FILE, $/);
- open(FILE, "< $file\0") or die $!;
- my $text = <FILE>;
- next unless $text;
- $text =~ s/\015?\012/\n/g;
- close(FILE);
- open(FILE, "> $file\0") or die $!;
- print FILE $text;
- close(FILE);
- print " LF->CR translate $file\n" if $verbose;
- } elsif (-B _ && $file =~ /\.bin$/ && $conv->is_macbinary($file)) {
- $conv->demacbinary($file);
- print " convert MacBinary $file\n" if $verbose;
- } elsif (-f _) {
- print " left alone $file\n" if $verbose;
+ } elsif (-B _ && $file =~ /\.bin$/ && $conv->is_macbinary($file)) {
+ $conv->demacbinary($file);
+ print " convert MacBinary $file\n" if $verbose;
+ } elsif (-f _) {
+ print " left alone $file\n" if $verbose;
+ }
}
- }
}
sub launch_file {
- require Mac::AppleEvents::Simple;
- Mac::AppleEvents::Simple->import;
- my($file, $use_cwd, $wait) = @_;
- my($editor, @editors);
+ require Mac::AppleEvents::Simple;
+ Mac::AppleEvents::Simple->import;
+ my($file, $use_cwd, $wait) = @_;
+ my($editor, @editors);
- $wait ||= 0;
- if ($use_cwd) {
- chomp(my $cwd = `pwd`);
- $file =~ s/^://;
- $file = "$cwd:$file";
- }
+ $wait ||= 0;
+ if ($use_cwd) {
+ chomp(my $cwd = `pwd`);
+ $file =~ s/^://;
+ $file = "$cwd:$file";
+ }
- @editors = qw(R*ch ALFA ttxt); # others?
- unshift @editors, $ENV{EDITOR} if $ENV{EDITOR};
- unshift @editors, $CPAN::Config->{pager}
- if $CPAN::Config->{pager} && length ($CPAN::Config->{pager}) == 4;
- foreach (@editors) {
- $editor = $Application{$_};
- last if $editor;
- }
+ @editors = qw(R*ch ALFA ttxt); # others?
+ unshift @editors, $ENV{EDITOR} if $ENV{EDITOR};
+ unshift @editors, $CPAN::Config->{pager}
+ if $CPAN::Config->{pager} && length ($CPAN::Config->{pager}) == 4;
+ foreach (@editors) {
+ $editor = $Application{$_};
+ last if $editor;
+ }
- do_event(qw/aevt odoc MACS/,
- q"'----':alis(@@), usin:alis(@@)",
- map {NewAliasMinimal $_} $file, $editor);
+ do_event(qw/aevt odoc MACS/,
+ q"'----':alis(@@), usin:alis(@@)",
+ map {NewAliasMinimal $_} $file, $editor);
}
sub look {
- require Mac::AppleEvents::Simple;
- Mac::AppleEvents::Simple->import;
- my($self, $cwd) = @_;
- $cwd = $self->dir or $self->get;
- $cwd = $self->dir;
- local $Mac::AppleEvents::Simple::SWITCH = 1;
- do_event(qw/aevt odoc MACS/,
- q"'----':alis(@@)",
- NewAliasMinimal($cwd));
+ require Mac::AppleEvents::Simple;
+ Mac::AppleEvents::Simple->import;
+
+ my($self, $cwd) = @_;
+ $cwd = $self->dir or $self->get;
+ $cwd = $self->dir;
+
+ local $Mac::AppleEvents::Simple::SWITCH = 1;
+ do_event(qw/aevt odoc MACS/,
+ q"'----':alis(@@)",
+ NewAliasMinimal($cwd));
}
1;
==== //depot/maint-5.6/macperl/macos/bundled_lib/blib/lib/MD5.pm#1 (text) ====
Index: perl/macos/bundled_lib/blib/lib/MD5.pm
--- perl/macos/bundled_lib/blib/lib/MD5.pm.~1~ Wed Oct 3 13:15:05 2001
+++ perl/macos/bundled_lib/blib/lib/MD5.pm Wed Oct 3 13:15:05 2001
@@ -0,0 +1,54 @@
+package MD5; # legacy stuff
+
+use strict;
+use vars qw($VERSION @ISA);
+
+$VERSION = '2.02'; # $Date: 2001/10/03 19:31:55 $
+
+require Digest::MD5;
+@ISA=qw(Digest::MD5);
+
+sub hash { shift->new->add(@_)->digest; }
+sub hexhash { shift->new->add(@_)->hexdigest; }
+
+1;
+__END__
+
+=head1 NAME
+
+MD5 - Perl interface to the MD5 Message-Digest Algorithm
+
+=head1 SYNOPSIS
+
+ use MD5;
+
+ $context = new MD5;
+ $context->reset();
+
+ $context->add(LIST);
+ $context->addfile(HANDLE);
+
+ $digest = $context->digest();
+ $string = $context->hexdigest();
+
+ $digest = MD5->hash(SCALAR);
+ $string = MD5->hexhash(SCALAR);
+
+=head1 DESCRIPTION
+
+The C<MD5> module is B<depreciated>. Use C<Digest::MD5> instead.
+
+The current C<MD5> module is just a wrapper around the C<Digest::MD5>
+module. It is provided so that legacy code that rely on the old
+interface still work and get the speed benefit of the new module.
+
+In addition to the methods provided for C<Digest::MD5> objects, this
+module provide the class methods MD5->hash() and MD5->hexhash() that
+basically do the same as the md5() and md5_hex() functions provided by
+C<Digest::MD5>.
+
+=head1 SEE ALSO
+
+L<Digest::MD5>
+
+=cut
==== //depot/maint-5.6/macperl/macos/bundled_lib/t/MD5/md5.t#1 (text) ====
Index: perl/macos/bundled_lib/t/MD5/md5.t
--- perl/macos/bundled_lib/t/MD5/md5.t.~1~ Wed Oct 3 13:15:05 2001
+++ perl/macos/bundled_lib/t/MD5/md5.t Wed Oct 3 13:15:05 2001
@@ -0,0 +1,173 @@
+######################### We start with some black magic to print on failure.
+
+# Change 1..1 below to 1..last_test_to_print .
+# (It may become useful if the test is moved to ./t subdirectory.)
+
+BEGIN {print "1..14\n";}
+END {print "not ok 1\n" unless $loaded;}
+use MD5;
+$loaded = 1;
+print "ok 1\n";
+
+######################### End of black magic.
+
+# Insert your test code below (better if it prints "ok 13"
+# (correspondingly "not ok 13") depending on the success of chunk 13
+# of the test code):
+
+package MD5Test;
+
+# 2: Constructor
+
+print (($md5 = new MD5) ? "ok 2\n" : "not ok 2\n");
+
+# 3: Basic test data as defined in RFC 1321
+
+%data = (
+ "" => "d41d8cd98f00b204e9800998ecf8427e",
+ "a" => "0cc175b9c0f1b6a831c399e269772661",
+ "abc" => "900150983cd24fb0d6963f7d28e17f72",
+ "message digest"
+ => "f96b697d7cb7938d525a2f31aaf161d0",
+ "abcdefghijklmnopqrstuvwxyz"
+ => "c3fcd3d76192e4007dfb496cca67e13b",
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
+ => "d174ab98d277d9f5a5611c2c9f419d9f",
+ "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
+ => "57edf4a22be3c955ac49da2e2107b67a",
+);
+
+$failed = 0;
+foreach (sort(keys(%data)))
+{
+ $md5->reset;
+ $md5->add($_);
+ $digest = $md5->digest;
+ $hex = unpack("H*", $digest);
+ if ($hex ne $data{$_}) {
+ print STDERR "\$md5->digest: $_\n";
+ print STDERR "expected: $data{$_}\n",
+ "got : $hex\n";
+ $failed++;
+ }
+
+ if (Digest::MD5::md5($_) ne $digest) {
+ print STDERR "md5($_) failed\n";
+ $failed++;
+ }
+
+ if (Digest::MD5::md5_hex($_) ne $hex) {
+ print STDERR "md5_hex($_) failed\n";
+ $failed++;
+ }
+
+ # same stuff ending with $md5->hexdigest instead
+ $md5->reset;
+ $md5->add($_);
+ $hex = $md5->hexdigest;
+ if ($hex ne $data{$_}) {
+ print STDERR "\$md5->hexdigest: $_\n";
+ print STDERR "expected: $data{$_}\n",
+ "got : $hex\n";
+ $failed++;
+ }
+}
+print ($failed ? "not ok 3\n" : "ok 3\n");
+
+# 4: Various flavours of file-handle to addfile
+
+open(F, "<$0");
+
+$md5->reset;
+
+$md5->addfile(F);
+$hex = $md5->hexdigest;
+print ($hex ne '' ? "ok 4\n" : "not ok 4\n");
+
+$orig = $hex;
+
+# 5: Fully qualified with ' operator
+
+seek(F, 0, 0);
+$md5->reset;
+$md5->addfile(MD5Test'F);
+$hex = $md5->hexdigest;
+print ($hex eq $orig ? "ok 5\n" : "not ok 5\n");
+
+# 6: Fully qualified with :: operator
+
+seek(F, 0, 0);
+$md5->reset;
+$md5->addfile(MD5Test::F);
+$hex = $md5->hexdigest;
+print ($hex eq $orig ? "ok 6\n" : "not ok 6\n");
+
+# 7: Type glob
+
+seek(F, 0, 0);
+$md5->reset;
+$md5->addfile(*F);
+$hex = $md5->hexdigest;
+print ($hex eq $orig ? "ok 7\n" : "not ok 7\n");
+
+# 8: Type glob reference (the prefered mechanism)
+
+seek(F, 0, 0);
+$md5->reset;
+$md5->addfile(\*F);
+$hex = $md5->hexdigest;
+print ($hex eq $orig ? "ok 8\n" : "not ok 8\n");
+
+# 9: File-handle passed by name (really the same as 6)
+
+seek(F, 0, 0);
+$md5->reset;
+$md5->addfile("MD5Test::F");
+$hex = $md5->hexdigest;
+print ($hex eq $orig ? "ok 9\n" : "not ok 9\n");
+
+# 10: Other ways of reading the data -- line at a time
+
+seek(F, 0, 0);
+$md5->reset;
+while (<F>)
+{
+ $md5->add($_);
+}
+$hex = $md5->hexdigest;
+print ($hex eq $orig ? "ok 10\n" : "not ok 10\n");
+
+# 11: Input lines as a list to add()
+
+seek(F, 0, 0);
+$md5->reset;
+$md5->add(<F>);
+$hex = $md5->hexdigest;
+print ($hex eq $orig ? "ok 11\n" : "not ok 11\n");
+
+# 12: Random chunks up to 128 bytes
+
+seek(F, 0, 0);
+$md5->reset;
+while (read(F, $hexata, (rand % 128) + 1))
+{
+ $md5->add($hexata);
+}
+$hex = $md5->hexdigest;
+print ($hex eq $orig ? "ok 12\n" : "not ok 12\n");
+
+# 13: All the data at once
+
+seek(F, 0, 0);
+$md5->reset;
+undef $/;
+$data = <F>;
+$hex = $md5->hexhash($data);
+print ($hex eq $orig ? "ok 13\n" : "not ok 13\n");
+
+close(F);
+
+# 14: Using static member function
+
+$hex = MD5->hexhash($data);
+print ($hex eq $orig ? "ok 14\n" : "not ok 14\n");
==== //depot/maint-5.6/macperl/macos/lib/Mac/AETE/App.pm#1 (text) ====
Index: perl/macos/lib/Mac/AETE/App.pm
--- perl/macos/lib/Mac/AETE/App.pm.~1~ Wed Oct 3 13:15:05 2001
+++ perl/macos/lib/Mac/AETE/App.pm Wed Oct 3 13:15:05 2001
@@ -0,0 +1,242 @@
+#
+# # Copyright (c) 1999 David Schooley. All rights reserved. This program is
+# free software; you can redistribute it and/or modify it under the same
+# terms as Perl itself.
+
+########################################################################
+# #
+# Do the following: #
+# See if the app is running, if so, send the GetAETE event to it. #
+# If it is not running, see if it has a sisz resource, #
+# if so, launch it and send the GetAETE event to it. #
+# if not, read in the aete directly. #
+# #
+########################################################################
+
+package Mac::AETE::App;
+
+=head1 NAME
+
+Mac::AETE::App - reads the Macintosh Apple event dictionary from an application.
+
+
+=head1 SYNOPSIS
+
+ use Mac::AETE::App;
+ use Mac::AETE::Format::Dictionary;
+
+ $app = App->new("My Application");
+ $formatter = Dictionary->new;
+ $app->set_format($formatter);
+ $app->read;
+ $app->write;
+
+
+=head1 DESCRIPTION
+
+The App module simplifies reading the Apple event dictionary from an application.
+It will launch the application if necessary to obtain the dictionary.
+
+=head2 Methods
+
+=over 10
+
+=item new
+
+Example: ($name is the name of the application.)
+
+ use Mac::AETE::App;
+ use Mac::AETE::Format::Dictionary;
+
+ $app = App->new($aete_handle, $name);
+
+=item read
+
+(Inherited from Mac::AETE::Parser.)
+
+Reads the data contained in the AETE resource or handle. Example:
+
+ $app->read;
+
+=item set_format
+
+(Inherited from Mac::AETE::Parser.)
+
+Sets the output formatter used during by the 'write' subroutine. Example:
+
+ $formatter = Dictionary->new;
+ $app->set_format($formatter);
+
+
+=item copy
+
+(Inherited from Mac::AETE::Parser.)
+
+Copies all suites from one Parser object into another. Example:
+
+ $aete2 = Parser->new($aete_handle2, $another_name);
+ $app->copy($aete2);
+
+copies the suites from $aete2 into $aete.
+
+=item merge
+
+(Inherited from Mac::AETE::Parser.)
+
+Merges suites from one Parser object into another. Only the suites that exist in
+both objects will be replaced. Example:
+
+ $aete3 = Parser->new($aete_handle2, $another_name);
+ $app->merge($aete3);
+
+=item write
+
+(Inherited from Mac::AETE::Parser.)
+
+Prints the contents of the AETE or AEUT resource using the current formatter.
+
+ $app->write;
+
+=back
+
+=head1 INHERITANCE
+
+Inherits from Mac::AETE::Parser.
+
+=head1 AUTHOR
+
+David Schooley <F<[email protected]>>
+
+=cut
+
+
+use strict;
+use Mac::AETE::Parser;
+use Mac::AppleEvents;
+use Mac::Files;
+use Mac::Memory;
+use Mac::Processes;
+use Mac::Resources;
+use File::Basename;
+
+use Carp;
+
+@Mac::AETE::App::ISA = qw(Mac::AETE::Parser);
+
+sub new {
+ my ($type, $target) = @_;
+ my $self = {};
+ my $aete_handle;
+
+ my($name, $running) = &get_app_status_and_launch($target);
+ return unless $name;
+
+ $self->{_target} = $name;
+
+ if ($running) {
+ unless ($aete_handle = get_aete_via_event($target)) {
+ carp("The application is not scriptable");
+ return;
+ }
+ } else {
+ my $RF = OpenResFile($self->{_target});
+ if ( !defined($RF) || $RF == 0) {
+ carp("No Resource Fork available for $target");
+ return;
+ }
+ my $temp_handle = Get1Resource('aete', 0);
+ if (!defined($temp_handle) || $temp_handle == 0) {
+ carp("Application '$self->{_target}' is not scriptable (App.pm)");
+ return;
+ }
+ $aete_handle = new Handle $temp_handle->get;
+ CloseResFile($RF);
+ }
+
+ my $newself = Mac::AETE::Parser->new($aete_handle, $target);
+
+ @{$newself}{keys %{$self}} = values %{$self};
+
+ return bless $newself, $type;
+}
+
+sub get_app_status_and_launch
+{
+ my ($app_path) = @_;
+ my ($name, $path, $suffix, $running, $ok_to_launch, $pname, $launch);
+ my ($psn, $psi);
+
+ $running = 0;
+ fileparse_set_fstype("MacOS");
+ ($name,$path,$suffix) = fileparse($app_path, "");
+ for $psn (keys %Process) {
+ $pname = $Process{$psn}->processName;
+# print "$pname", " $name\n";
+ $running = 1, last if $pname eq $name;
+ }
+ if (!$running) {
+ my $RF = OpenResFile($app_path);
+ if (!defined($RF) || $RF == 0) {
+ carp("No Resource Fork available for '$app_path': $^E");
+ return;
+ }
+ my $check_resource = Get1Resource('scsz', 0);
+ if (!defined($check_resource) || $check_resource == 0) {
+ $check_resource = Get1Resource('scsz', 128);
+ }
+ $ok_to_launch = defined($check_resource) && $check_resource;
+ CloseResFile($RF); # don't do anything with the resource now!
+ if ($ok_to_launch) {
+ $launch = new LaunchParam(
+ launchControlFlags => eval(launchContinue + launchNoFileFlags + launchDontSwitch),
+ launchAppSpec => $app_path
+ );
+ LaunchApplication $launch;
+ $running = 1;
+ }
+ }
+
+ while (($psn, $psi) = each(%Process)) {
+ $pname = $psi->processName;
+ $running = 1, last if $pname eq $name;
+ }
+ $name = $app_path if $name !~ /:/;
+ ($name, $running);
+}
+
+sub get_aete_via_event
+{
+ my($target) = @_;
+ my $info = FSpGetFInfo($target);
+
+ my $addr_desc = AECreateDesc(typeApplSignature, $info->fdCreator);
+ my $event = AEBuildAppleEvent('ascr', 'gdte', 'sign', $info->fdCreator, 0, 0, , "'----':0");
+ my $reply = AESend($event, kAEWaitReply);
+ my @handles;
+ if ($reply) {
+ my $result_desc = AEGetParamDesc($reply, keyDirectObject);
+ if ($result_desc->type eq typeAEList) {
+ for (my $i = 1; $i <= AECountItems($result_desc); $i++) {
+ my $tmp_desc = AEGetNthDesc($result_desc, $i)
+ or carp("Bad result from GetAETE!\n") and return;
+ my $aete_handle = $tmp_desc->data
+ or carp("Bad result from GetAETE!\n") and return;
+ my $aete = new Handle($aete_handle->get)
+ or carp("Bad result from GetAETE!\n") and return;
+ push @handles, $aete;
+ }
+ } else {
+ my $aete_handle = $result_desc->data
+ or carp("Bad result from GetAETE!\n") and return;
+ my $aete = new Handle($aete_handle->get)
+ or carp("Bad result from GetAETE!\n") and return;
+ push @handles, $aete;
+ }
+ AEDisposeDesc $result_desc;
+ AEDisposeDesc $reply;
+ }
+ AEDisposeDesc $event;
+ AEDisposeDesc $addr_desc;
+ \@handles;
+}
+
==== //depot/maint-5.6/macperl/macos/lib/Mac/AETE/Dialect.pm#1 (text) ====
Index: perl/macos/lib/Mac/AETE/Dialect.pm
--- perl/macos/lib/Mac/AETE/Dialect.pm.~1~ Wed Oct 3 13:15:05 2001
+++ perl/macos/lib/Mac/AETE/Dialect.pm Wed Oct 3 13:15:05 2001
@@ -0,0 +1,156 @@
+# Copyright (c) 1999 David Schooley. All rights reserved. This program is
+# free software; you can redistribute it and/or modify it under the same
+# terms as Perl itself.
+
+
+package Mac::AETE::Dialect;
+
+=head1 NAME
+
+Mac::AETE::Dialect - reads the Macintosh Apple event dictionary from an
+Applescript dialect file.
+
+
+=head1 SYNOPSIS
+
+ use Mac::AETE::App;
+ use Mac::AETE::Dialect;
+ use Mac::AETE::Format::Dictionary;
+
+ $aeut = Dialect->new();
+ $aeut->read();
+
+ $app = App->new("My Application");
+ $formatter = Dictionary->new;
+ $app->set_format($formatter);
+ $app->read;
+ $app->merge($aeut);
+ $app->write;
+
+
+=head1 DESCRIPTION
+
+The data in Dialect objects can be merged into a Parser or App object
+to make a complete Apple event dictionary. The module will locate the proper
+AppleScript dialect file in the system folder.
+
+See Mac::AETE::Parser and Mac::AETE::App for more details.
+
+=head2 Methods
+
+=over 10
+
+=item new
+
+Example:
+
+ use Mac::AETE::Dialect;
+
+ $app = Dialect->new;
+
+=item read
+
+(Inherited from Mac::AETE::Parser.)
+
+Reads the data contained in the AETE resource or handle. Example:
+
+ $app->read;
+
+=back
+
+=head1 INHERITANCE
+
+Inherits from Mac::AETE::Parser.
+
+=head1 AUTHOR
+
+David Schooley <F<[email protected]>>
+
+=cut
+
+use strict;
+use Mac::AETE::Parser;
+use Mac::Memory;
+use Mac::Resources;
+use Mac::MoreFiles;
+use Mac::Files;
+
+use Carp;
+
+@Mac::AETE::Dialect::ISA = qw (Mac::AETE::Parser);
+
+sub _filter
+{
+ my ($spec, $data) = @_;
+ my ($creator, $type);
+ my $return_value = 0;
+
+ ($creator, $type) = MacPerl::GetFileInfo($spec);
+
+ if ($creator && $type && $creator eq 'ascr' && $type eq 'dlct') {
+ $$data = $spec;
+ $return_value = 1;
+ }
+ $return_value;
+}
+
+sub new {
+ my ($type, $dialect_file) = @_;
+ my ($data, $path, $ref);
+ my $self;
+
+ if (!defined $dialect_file) {
+ $path = FindFolder(kOnSystemDisk, kExtensionFolderType , kDontCreateFolder) || croak("Couldn't find the extensions folder");
+ $ref = \&_filter;
+ FSpIterateDirectory($path, 2, $ref, \$dialect_file);
+
+ if (!$dialect_file) {
+ $path = FindFolder(kOnSystemDisk, kSystemFolderType , kDontCreateFolder) || croak("Couldn't find the system folder");
+ FSpIterateDirectory($path, 3, $ref, \$dialect_file);
+ }
+ }
+ if ($dialect_file) {
+ my $RF = OpenResFile($dialect_file);
+ if (!defined($RF) || $RF == 0) {
+ croak("No Resource Fork available for $dialect_file");
+ }
+ my $aete_handle = Get1Resource("aeut", 0);
+ if (!defined($aete_handle) || $aete_handle == 0) {
+ croak("Application is not scriptable");
+ }
+ $self = Mac::AETE::Parser->new($aete_handle, $dialect_file);
+ $self->{_resource_fork} = $RF;
+ } else {
+ croak("Couldn't find a dialect file");
+ }
+ return bless $self, $type;
+}
+
+sub DESTROY {
+ my $self = shift;
+ CloseResFile $self->{_resource_fork} if defined $self->{_resource_fork};
+}
+
+
+sub init
+{
+ my ($self) = @_;
+
+ $self->{_handle_index} = 0;
+ my $RF = OpenResFile($self->{_target});
+ if ( !defined($RF) || $RF == 0) {
+ croak("No Resource Fork available for $self->{_target}");
+ }
+ $self->{_resource_fork} = $RF;
+ my $aete_handle = GetResource("aeut", 0);
+ if (!defined($aete_handle) || $aete_handle == 0) {
+ croak("Application is not scriptable");
+ }
+ $self->{_resource} = $aete_handle;
+ $self->{_inited} = 1;
+
+ $DB::single = 1;
+}
+
+
+1;
==== //depot/maint-5.6/macperl/macos/lib/Mac/AETE/Format/Converter.pm#1 (text) ====
Index: perl/macos/lib/Mac/AETE/Format/Converter.pm
--- perl/macos/lib/Mac/AETE/Format/Converter.pm.~1~ Wed Oct 3 13:15:05 2001
+++ perl/macos/lib/Mac/AETE/Format/Converter.pm Wed Oct 3 13:15:05 2001
@@ -0,0 +1,137 @@
+# Copyright (c) 1999 David Schooley. All rights reserved. This program is
+# free software; you can redistribute it and/or modify it under the same
+# terms as Perl itself.
+
+package Mac::AETE::Format::Converter;
+
+@req = qw(OPT REQ);
+
+@list = qw(SINGLE LIST);
+@enum = qw(NOENUM ENUM);
+@rdonly = qw(RDONLY RDWR);
+@change = qw(NOCHANGE CHANGE);
+
+@suite_list = ();
+
+sub new {
+ my $type = shift;
+ my $target = shift;
+ my $self = {};
+ return bless $self, $type;
+}
+
+sub write_title
+{
+ my ($self, $title) = @_;
+
+ print "\@TITLE \"Events for $title\"\n";
+}
+
+sub write_version
+{
+ my ($self, $version) = @_;
+
+ print "\@VERSION $version\n";
+
+}
+
+sub start_suite
+{
+ my ($self, $name, $desc, $id) = @_;
+
+ print "\@SUITE \"$name\", \"$desc\", \'$id\'\n\n";
+
+}
+
+sub end_suite
+{
+ print "\n";
+}
+
+sub start_event
+{
+ my ($self, $name, $desc, $class, $id) = @_;
+
+ print "\@EVENT \"$name\", \"$desc\", \'$class\', \'$id\'\n";
+
+
+}
+
+sub end_event
+{
+ print "\n";
+}
+
+sub write_reply
+{
+ my ($self, $type, $desc, $req, $list, $enum) = @_;
+
+ print "\@REPLY \'$type\', \"$desc\", $req[$req], $list[$list], $enum[$enum]\n";
+}
+
+sub write_dobj
+{
+ my ($self, $type, $desc, $req, $list, $enum, $change) = @_;
+
+ print "\@DIRECT \'$type\', \"$desc\", $req[$req], $list[$list], $enum[$enum], $change[$change]\n";
+}
+
+sub write_param
+{
+ my ($self, $name, $id, $type, $desc, $req, $list, $enum) = @_;
+
+ print "\@PARAM \"$name\", \'$id\', \'$type\', \"$desc\", $req[$req], $list[$list], $enum[$enum]\n";
+}
+
+sub begin_class
+{
+ my ($self, $name, $id, $desc) = @_;
+
+ print "\@CLASS \"$name\", \'$id\', \"$desc\"\n";
+}
+
+sub end_class
+{
+ print "\n"
+}
+
+sub write_property
+{
+ my ($self, $name, $id, $class, $desc, $list, $enum, $rdonly) = @_;
+
+ print "\@PROPERTY \"$name\", \'$id\', \'$class\', \"$desc\", $list[$list], $enum[$enum], $rdonly[$rdonly]\n";
+}
+
+sub write_element
+{
+ my ($self, $name, @keys) = @_;
+
+ print "\@ELEMENT \'$name\'";
+ foreach (@keys) {
+ print "\, \'$_\'";
+ }
+ print "\n";
+}
+
+sub begin_enumeration
+{
+ my ($self, $id) = @_;
+
+ print "\n\@ENUMERATION \'$id\'\n";
+}
+
+sub end_enumeration
+{
+ print "\n";
+}
+
+sub write_enum
+{
+ my ($self, $name, $id, $comment) = @_;
+
+ print "\@ENUM \"$name\", \'$id\', \"$comment\"\n";
+}
+
+
+
+1;
==== //depot/maint-5.6/macperl/macos/lib/Mac/AETE/Format/Dictionary.pm#1 (text) ====
Index: perl/macos/lib/Mac/AETE/Format/Dictionary.pm
--- perl/macos/lib/Mac/AETE/Format/Dictionary.pm.~1~ Wed Oct 3 13:15:05 2001
+++ perl/macos/lib/Mac/AETE/Format/Dictionary.pm Wed Oct 3 13:15:05 2001
@@ -0,0 +1,174 @@
+package Mac::AETE::Format::Dictionary;
+
+
+sub new {
+ my $type = shift;
+ my $target = shift;
+ my $self = {};
+ return bless $self, $type;
+}
+
+@req = qw(optional required);
+
+@list = qw(single list);
+@enum = qw(non-enum enumerated);
+@rdonly = qw(read-only read-write);
+@change = qw(no-change change);
+
+sub write_title
+{
+ my ($self, $title) = @_;
+ print "Title: $title\n";
+}
+
+sub write_version
+{
+ my ($self, $version) = @_;
+ print "Version: $version\n";
+}
+
+
+sub start_suite
+{
+ my ($self, $name, $desc, $id) = @_;
+
+ print <<"EOT"
+
+============================================================
+Suite: $name, $desc
+============================================================
+Suite ID: '$id'
+
+EOT
+
+}
+
+sub end_suite
+{
+ print "\n";
+}
+
+sub start_event
+{
+ my ($self, $name, $desc, $class, $id) = @_;
+
+ print <<"EOT"
+Event: $name, $desc
+ Class: '$class'
+ ID: '$id'
+EOT
+}
+
+sub end_event
+{
+ print "\n";
+}
+
+sub write_reply
+{
+ my ($self, $type, $desc, $req, $list, $enum) = @_;
+
+ print <<"EOT"
+ Reply: $desc
+ Type: '$type'
+ Flags: $req[$req], $list[$list], $enum[$enum]
+EOT
+}
+
+sub write_dobj
+{
+ my ($self, $type, $desc, $req, $list, $enum, $change) = @_;
+
+ print <<"EOT"
+ Direct Object: $desc
+ Type: '$type'
+ Flags: $req[$req], $list[$list], $enum[$enum], $change[$change]
+EOT
+}
+
+sub write_param
+{
+ my ($self, $name, $id, $type, $desc, $req, $list, $enum) = @_;
+
+ print <<"EOT"
+ Parameter: $name, $desc
+ ID: '$id'
+ Type: '$type'
+ Flags: $req[$req], $list[$list], $enum[$enum]
+EOT
+}
+
+sub begin_class
+{
+ my ($self, $name, $id, $desc) = @_;
+
+ print <<"EOT"
+Object Class: $name, $desc
+ ID: '$id'
+EOT
+}
+
+sub end_class
+{
+ print "\n\n"
+}
+
+sub write_comparison
+{
+ my ($self, $name, $id, $desc) = @_;
+
+ print <<"EOT"
+
+Comparision: $name, $desc
+ ID: '$id'
+
+EOT
+}
+
+sub write_property
+{
+ my ($self, $name, $id, $class, $desc, $list, $enum, $rdonly) = @_;
+
+ print <<"EOT"
+ Property: $name, $desc
+ ID: '$id'
+ Class: '$class'
+ Flags: $list[$list], $enum[$enum], $rdonly[$rdonly]
+EOT
+}
+
+sub write_element
+{
+ my ($self, $name, @keys) = @_;
+
+print " Elements: $name";
+
+foreach (@keys) {
+ print "\, \'$_\'";
+ }
+}
+
+sub begin_enumeration
+{
+ my ($self, $id) = @_;
+
+ print <<"EOT"
+Enumeration: '$id'
+EOT
+}
+
+sub end_enumeration
+{
+ print "\n";
+}
+
+sub write_enum
+{
+ my ($self, $name, $id, $comment) = @_;
+
+ print <<"EOT"
+ $name, $comment, '$id'
+EOT
+}
+
+1;
==== //depot/maint-5.6/macperl/macos/lib/Mac/AETE/Format/Glue.pm#1 (text) ====
Index: perl/macos/lib/Mac/AETE/Format/Glue.pm
--- perl/macos/lib/Mac/AETE/Format/Glue.pm.~1~ Wed Oct 3 13:15:05 2001
+++ perl/macos/lib/Mac/AETE/Format/Glue.pm Wed Oct 3 13:15:05 2001
@@ -0,0 +1,370 @@
+package Mac::AETE::Format::Glue;
+use Data::Dumper;
+use Fcntl;
+use File::Basename;
+use File::Path;
+use Mac::AETE::Parser;
+use Mac::Glue;
+use MLDBM ('DB_File', $Mac::Glue::SERIALIZER);
+
+use strict;
+use vars qw(@ISA $VERSION $TYPE);
+
+$TYPE = 'McPp';
+
+@ISA = qw(Mac::AETE::Parser);
+$VERSION = '0.32';
+
+sub fixname {
+ (my $ev = shift) =~ s/[^a-zA-Z0-9_]/_/g;
+ $ev =~ s/^_+//;
+ $ev =~ s/_+$//;
+ return $ev;
+}
+
+sub doc_enums {
+ my $self = shift;
+ my($text, %n, %d);
+ return unless exists $self->{N};
+
+ $text = "=head2 Enumerations\n\n=over 4\n\n";
+ %n = %{$self->{N }};
+ %d = %{$self->{DN}};
+
+ foreach my $n (sort keys %n) {
+ $text .= "=item '$n'\n\n=over 4\n\n";
+ foreach my $e (keys %{$n{$n}}) {
+ $text .= sprintf("=item %s (%s)%s\n\n", $e, $n{$n}{$e}{id},
+ $n{$n}{$e}{desc} ne '' ? "\n\n$n{$n}{$e}{desc}" : '');
+ }
+ $text .= "=back\n\n";
+ }
+
+ $text .= "=back\n\n";
+ return $text;
+}
+
+sub doc_events {
+ my($self, $text, %e, %d) = $_[0];
+ return unless exists $self->{E};
+
+ $text = "=head2 Events\n\n=over 4\n\n";
+ %e = %{$self->{E }};
+ %d = %{$self->{DE}};
+ foreach my $e (sort keys %e) {
+ my($d, $p, %p);
+ $d = $e{$e}{params}{'----'}[1] if $e{$e}{params}{'----'}[1] ne 'null';
+ %p = map {($_, $e{$e}{params}{$_})} keys %{$e{$e}{params}};
+ my $dobj = delete $p{'----'};
+
+ my @keys = sort keys %p;
+ @keys = sort {
+ $b->[4] <=> $a->[4]
+ ||
+ $a->[0] cmp $b->[0]
+ } map {[
+ $_, $d{$e}{params}{$_}, @{$e{$e}{params}{$_}}
+ ]} @keys;
+
+ my $req;
+ $p = join ', ', map {
+ $req += !$_->[4];
+ ($req == 1? '[' : '') . "$_->[0] => $p{$_->[0]}[1]"
+ } @keys;
+ $p .= ']' if $req;
+
+ unshift @keys,
+ ['----', $d{$e}{params}{'----'}, @{$e{$e}{params}{'----'}}]
+ if $dobj;
+
+ $text .= sprintf("=item \$obj->%s(%s%s%s)\n\n%s\n\n%s",
+ $e, ($d ? $d : ''), ($p && $d ? ', ' : ''),
+ ($p ? $p : ''), "$d{$e}{desc} ($e{$e}{class}/$e{$e}{event})",
+ ($e{$e}{reply}[1] ? "Reply type: $e{$e}{reply}[0]\n\n" : ''));
+
+ if ($d || $p) {
+ $text .= "Parameters:\n\n";
+ $text .= join '', map {
+ my $x = $_->[0] eq '----' ? 'direct object' : $_->[0];
+ " $x ($_->[2]): $_->[1]\n"
+ } @keys;
+ $text .= "\n";
+ }
+ $text .= "\n";
+ }
+ $text .= "=back\n\n";
+ return $text;
+}
+
+sub doc_classes {
+ my($self, $text, %c, %d) = $_[0];
+ $text = "=head2 Classes\n\n=over 4\n\n";
+ return unless $self->{C};
+ %c = %{$self->{C }};
+ %d = $self->{DC} ? %{$self->{DC}} : ();
+
+ foreach my $c (sort keys %c) {
+ my(%p, %e, %n);
+ %p = map {($_, $c{$c}{properties}{$_})} keys %{$c{$c}{properties}};
+ %e = map {($_, $c{$c}{elements}{$_})} keys %{$c{$c}{elements}};
+
+ foreach (keys %p) {
+ if (! $_ && $p{$_}[0] eq 'c@#!') {
+ delete $p{$_};
+ }
+ }
+
+ $text .= sprintf("=item %s (%s)%s\n\n", $c, $c{$c}{id},
+ ($d{$c}{desc} ? "\n\n$d{$c}{desc}" : ''));
+
+ if (values %p) {
+ $text .= "Properties:\n\n";
+ $text .= join '',
+ map {
+ sprintf(" %s (%s/%s): %s%s\n", $_,
+ $c{$c}{properties}{$_}[0],
+ ($c{$c}{properties}{$_}[0] eq 'c@#^'
+ ? $self->{CLASSNAMES}{$c{$c}{properties}{$_}[1]}
+ : $c{$c}{properties}{$_}[1]),
+ $d{$c}{properties}{$_},
+ ($c{$c}{properties}{$_}[4] ? ' (read-only)' : '')
+ )
+ } (sort keys %p);
+ $text .= "\n";
+ }
+
+ if (values %e) {
+ $text .= "Elements:\n\n " . join(', ', sort
+ map { exists $self->{CLASSNAMES}{$_} ? $self->{CLASSNAMES}{$_} : $_ }
+ map { while (length($_) < 4) { $_ = "$_ " }; $_ }
+ keys %e) . "\n\n";
+ }
+
+ }
+ $text .= "=back\n\n";
+
+ return $text;
+}
+
+sub finish {
+ my($self, $nopod) = @_;
+ my %dbm;
+
+ my $path = dirname($self->{OUTPUT});
+ mkpath($path);
+ die "Couldn't create path: $!" unless -d $path;
+
+ unlink $self->{OUTPUT} if $self->{DELETE};
+
+ if (!tie %dbm, 'MLDBM', $self->{OUTPUT}, O_CREAT|O_RDWR|O_EXCL, 0640) {
+ warn "Can't tie to '$self->{OUTPUT}': $!";
+ return;
+ }
+
+ $dbm{ENUM} = $self->{N};
+ $dbm{CLASS} = $self->{C};
+ $dbm{EVENT} = $self->{E};
+ $dbm{COMPARISON} = $self->{P};
+ $dbm{ID} = $self->{ID};
+
+ MacPerl::SetFileInfo('McPL', $TYPE, $self->{OUTPUT});
+ return 1 if $nopod;
+
+ foreach (@{$self}{qw(START FINISH)}) {
+ s/__APPNAME__/$self->{TITLE}/g;
+ s/__APPID__/$self->{ID}/g;
+ }
+
+ local *FILE;
+ my $file = $$self{OUTPUT};
+ chop($file) while length(basename("$file.pod")) > 27;
+ $file .= ".pod";
+ unlink $file if $self->{DELETE};
+
+ sysopen FILE, $file, O_CREAT|O_WRONLY|O_EXCL
+ or die "Can't create file '$file': $!";
+ MacPerl::SetFileInfo(qw(Â
uck TEXT), $file);
+
+ print FILE $self->{START};
+ print FILE doc_events($self);
+ print FILE doc_classes($self);
+ print FILE doc_enums($self);
+ print FILE $self->{FINISH};
+
+ return 1;
+}
+
+sub new {
+ my $type = shift or die;
+ my $output = shift or die;
+ my $delete = shift;
+ my $self = {OUTPUT => $output, _init()};
+ $self->{DELETE} = $delete || 0;
+ return bless($self, $type);
+}
+
+sub write_title {
+ my($self, $title) = @_;
+ $self->{ID} = (MacPerl::GetFileInfo($title))[0];
+ $self->{TITLE} = basename($self->{OUTPUT});
+}
+
+sub write_version {
+ my($self, $version) = @_;
+ $self->{VERSION} = $version;
+}
+
+sub start_suite {
+ my($self, $name, $desc, $id) = @_;
+}
+
+sub end_suite {
+ my($self) = @_;
+}
+
+sub start_event {
+ my($self, $name, $desc, $class, $id, $ev, $en, $c) = @_;
+ $ev = lc fixname($name);
+ $en = $ev;
+# $c = 2;
+# while (exists($self->{E}{$en})) {
+# $en = $ev . $c++;
+# }
+ @{$self->{E }{$en}}{qw(class event desc)} = ($class, $id, $desc);
+ $self->{DE}{$en}{desc} = $desc;
+ $self->{CE} = $en;
+}
+
+sub end_event {
+ my($self) = @_;
+ undef($self->{CE});
+}
+
+sub write_reply {
+ my($self, $type, $desc, $req, $list, $enum) = @_;
+ $self->{E }{$self->{CE}}{reply} = [$type, $req, $list, $enum]; # desc?
+ $self->{DE}{$self->{CE}}{reply} = $desc;
+}
+
+sub write_dobj {
+ my($self, $type, $desc, $req, $list, $enum, $change) = @_;
+ $self->{E }{$self->{CE}}{params}{'----'} = ['----', $type, $req, $list, $enum, $change]; # desc?
+ $self->{DE}{$self->{CE}}{params}{'----'} = $desc;
+}
+
+sub write_param {
+ my($self, $name, $id, $type, $desc, $req, $list, $enum) = @_;
+ my $ev = lc fixname($name);
+ $self->{E }{$self->{CE}}{params}{$ev} = [$id, $type, $req, $list, $enum]; # desc?
+ $self->{DE}{$self->{CE}}{params}{$ev} = $desc;
+}
+
+sub begin_class {
+ my($self, $name, $id, $desc, $ev, $en, $c) = @_;
+ $ev = lc fixname($name);
+ $en = $ev;
+# $c = 2;
+# while (exists($self->{C}{$en})) {
+# $en = $ev . $c++;
+# }
+ $self->{C }{$en}{id} = $id;
+ $self->{C }{$en}{desc} = $desc;
+ $self->{DC}{$en}{desc} = $desc;
+ $self->{CC} = $en;
+ $self->{CLASSNAMES}{$id} = $en unless exists $self->{CLASSNAMES}{$id};
+}
+
+sub end_class {
+ my($self) = @_;
+ undef($self->{CE});
+}
+
+sub write_property {
+ my($self, $name, $id, $class, $desc, $list, $enum, $rdonly) = @_;
+ my $ev = lc fixname($name);
+ $self->{C }{$self->{CC}}{properties}{$ev} = [$id, $class, $list, $enum, $rdonly]; # desc?
+ $self->{DC}{$self->{CC}}{properties}{$ev} = $desc;
+}
+
+sub end_properties {
+ my($self) = @_;
+}
+
+sub write_element {
+ my($self, $name, @keys) = @_;
+ my $ev = lc fixname($name);
+ $self->{C }{$self->{CC}}{elements}{$ev} = [@keys];
+}
+
+sub write_comparison {
+ my($self, $name, $id, $desc) = @_;
+ $self->{P }{$name} = [$id, $desc];
+# print "# OK\n";
+}
+
+sub begin_enumeration {
+ my($self, $id) = @_;
+ $self->{N}{$id} = {};
+ $self->{'NE'} = $id;
+}
+
+sub end_enumeration {
+ my $self = shift;
+ undef $self->{'NE'};
+}
+
+sub write_enum {
+ my($self, $name, $id, $desc, $ev, $en, $c) = @_;
+ $en = $ev = lc fixname($name);
+# $c = 2;
+# while (exists $self->{N}{$en}) {
+# $en = $ev . $c++;
+# }
+
+ $self->{N }{$self->{'NE'}}{$en}{id} = $id;
+ $self->{N }{$self->{'NE'}}{$en}{desc} = $desc;
+ $self->{DN}{$self->{'NE'}}{$en}{desc} = $desc;
+}
+
+sub _init {
+ my(%self);
+ $self{START} = <<'EOT';
+=head1 NAME
+
+__APPNAME__ Glue - Control __APPNAME__ app
+
+=head1 SYNOPSIS
+
+ use Mac::Glue;
+ my $obj = new Mac::Glue '__APPNAME__';
+
+=head1 DESCRIPTION
+
+See C<Mac::Glue> for complete documentation on base usage and framework.
+
+EOT
+
+ $self{FINISH} = <<EOT;
+=head1 AUTHOR
+
+Glue created by ${\($ENV{'USER'} || '????')}
+using F<gluemac> by Chris Nandor and the Mac::AETE modules
+by David C. Schooley.
+
+Copyright (c) ${\((localtime)[5] + 1900)}. All rights reserved. This program is
+free software; you can redistribute it and/or modify it under the terms
+of the Artistic License, distributed with Perl.
+
+=head1 SEE ALSO
+
+Mac::AppleEvents, Mac::AppleEvents::Simple, macperlcat, Inside Macintosh:
+Interapplication Communication, Mac::Glue, Mac::AETE.
+
+=cut
+EOT
+
+ return %self;
+}
+1;
+
+__END__
==== //depot/maint-5.6/macperl/macos/lib/Mac/AETE/Parser.pm#1 (text) ====
Index: perl/macos/lib/Mac/AETE/Parser.pm
--- perl/macos/lib/Mac/AETE/Parser.pm.~1~ Wed Oct 3 13:15:05 2001
+++ perl/macos/lib/Mac/AETE/Parser.pm Wed Oct 3 13:15:05 2001
@@ -0,0 +1,478 @@
+#
+# # Copyright (c) 1999 David Schooley. All rights reserved. This program is
+# free software; you can redistribute it and/or modify it under the same
+# terms as Perl itself.
+
+# Data structures based on Chris Nandor's modifications to the original aeteconvert.
+
+=head1 NAME
+
+Mac::AETE::Parser - parses Macintosh AETE and AEUT resources.
+
+
+=head1 SYNOPSIS
+
+ use Mac::AETE::Parser;
+ use Mac::AETE::Format::Dictionary;
+
+ $aete = Parser->new($aete_handle, $name);
+ $formatter = Dictionary->new;
+ $aete->set_format($formatter);
+ $aete->read;
+ $aete->write;
+
+
+=head1 DESCRIPTION
+
+The Parser module serves as a base class for the Mac::AETE::App and Mac::AETE::Dialect modules.
+
+=head2 Methods
+
+=over 10
+
+=item new
+
+Example: ($aete_handle is a handle containing a valid AETE resource. $name is the name of the application.)
+
+ use Mac::AETE::Parser;
+ use Mac::AETE::Format::Dictionary;
+
+ $aete = Parser->new($aete_handle, $name);
+
+=item read
+
+Reads the data contained in the AETE resource or handle. Example:
+
+ $aete->read;
+
+
+=item set_format
+
+Sets the output formatter used during by the 'write' subroutine. Example:
+
+ $formatter = Dictionary->new;
+ $aete->set_format($formatter);
+
+
+=item copy
+
+Copies all suites from one Parser object into another. Example:
+
+ $aete2 = Parser->new($aete_handle2, $another_name);
+ $aete->copy($aete2);
+
+copies the suites from $aete2 into $aete.
+
+=item merge
+
+Merges suites from one Parser object into another. Only the suites that exist in
+both objects will be replaced. Example:
+
+ $aete3 = Parser->new($aete_handle2, $another_name);
+ $aete->merge($aete3);
+
+=item write
+
+Prints the contents of the AETE or AEUT resource using the current formatter.
+
+ $aete->write;
+
+=back
+
+=head1 INHERITANCE
+
+Parser does not inherit from any other modules.
+
+=head1 AUTHOR
+
+David Schooley <F<[email protected]>>
+
+The data structures are adapted from modifications made to the original
+aeteconvert script by Chris Nandor.
+
+=cut
+
+package Mac::AETE::Parser;
+
+use Data::Dumper;
+use strict;
+use Mac::Memory;
+use Carp;
+
+sub new {
+ my ($class, $handle, $target) = @_;
+ my $self = {};
+ bless $self, $class;
+
+ croak("Invalid Resource") if !defined $handle || !$handle;
+
+ if (ref($handle) eq 'ARRAY') {
+ $self->{_handles} = $handle;
+ } else {
+ $self->{_handles} = [$handle];
+ }
+ $self->{_target} = $target;
+ $self->{_suite_list} = ();
+
+ return $self;
+}
+
+sub set_format
+{
+ my ($self, $format) = @_;
+
+ $self->{_formatter} = $format;
+}
+
+
+# Copy suites from aete
+sub copy
+{
+ my ($self, $aete) = @_;
+ my ($suite_src, $suite_dest);
+
+
+ foreach $suite_src (@{$aete->{_suite_list}}) {
+ push @{$self->{_suite_list}}, $suite_src;
+ }
+}
+
+# Replace existing suites with suites from aete2
+sub merge
+{
+ my ($self, $aete) = @_;
+ my ($suite_src, $suite_dest);
+
+ foreach $suite_src (@{$aete->{_suite_list}}) {
+ foreach $suite_dest (@{$self->{_suite_list}}) {
+ if ($suite_dest->{_SIZE} == 0 && $suite_src->{_ID} eq $suite_dest->{_ID}) {
+ %$suite_dest = %$suite_src;
+ }
+ }
+ }
+}
+
+
+sub write {
+ my $self = shift;
+
+ croak("You have to assign a formatter before writing!")
+ if !defined $self->{_formatter};
+
+ my $form = $self->{_formatter};
+
+ $form->write_intro if $form->can('write_intro');
+ $form->write_title($self->{_target}) if $form->can('write_title');
+ $form->write_version($self->{_version}) if $form->can('write_version');
+
+ foreach my $suite (@{$self->{_suite_list}}) {
+ $form->start_suite(@$suite{qw[_NAME _DESC _ID]})
+ if $form->can('start_suite');
+
+ foreach my $event (@{$suite->{_event_list}}) {
+ my $reply = $event->{_REPLY};
+ my $dobj = $event->{_DOBJ};
+
+ $form->start_event(@{$event}{qw[_NAME _DESC _CLASS _ID]})
+ if $form->can('start_event');
+
+ $form->write_reply(@{$reply}{qw[_TYPE _DESC _REQ _LIST _ENUM]})
+ if $form->can('write_reply');
+
+ $form->write_dobj(@{$dobj}{qw[_TYPE _DESC _REQ _LIST _ENUM _CHANGE]})
+ if $form->can('write_dobj');
+
+ foreach my $param (@{$event->{_param_list}}) {
+ $form->write_param(
+ @{$param}{qw[_NAME _ID _TYPE _DESC _REQ _LIST _ENUM]}
+ ) if $form->can('write_param');
+ }
+ $form->end_event if $form->can('end_event');
+ }
+ foreach my $class (@{$suite->{_class_list}}) {
+ $form->begin_class(@{$class}{qw[_NAME _ID _DESC]})
+ if $form->can('begin_class');
+ $form->begin_properties if $form->can('begin_properties');
+ foreach my $prop (@{$class->{_property_list}}) {
+ $form->write_property(
+ @{$prop}{qw[_NAME _ID _CLASS _DESC _LIST _ENUM _RDWR]}
+ ) if $form->can('write_property');
+ }
+ $form->end_properties if $form->can('end_properties');
+ foreach my $element (@{$class->{_element_list}}) {
+ $form->write_element($element->{_CLASS}, @{$element->{_ID}})
+ if $form->can('write_element');
+ }
+ $form->end_class if $form->can('end_class');
+ }
+ foreach my $comp (@{$suite->{_comparison_list}}) {
+ $form->write_comparison(@{$comp}{qw[_NAME _ID _DESC]})
+ if $form->can('write_comparison');
+ }
+
+ foreach my $enumeration (@{$suite->{_enumeration_list}}) {
+ $form->begin_enumeration($enumeration->{_ID})
+ if $form->can('begin_enumeration');
+ foreach my $enum (@{$enumeration->{_enum_list}}) {
+ $form->write_enum(@{$enum}{qw[_NAME _ID _COMMENT]})
+ if $form->can('write_enum');
+ }
+ $form->end_enumeration if $form->can('end_enumeration');
+ }
+ $form->end_suite if $form->can('end_suite');
+ }
+ $form->write_finale if $form->can('write_finale');
+}
+
+sub read {
+ my $self = shift;
+
+ for my $handle (@{$self->{_handles}}) {
+
+ $self->{_handle} = $handle;
+ $self->{_handle_index} = 0;
+
+ my $header_data = $self->_scan(8);
+ my($version, $subVersion, $language, $script, $suiteCount)
+ = unpack("C C S S S", $header_data);
+
+ $self->{_version} = "$version.$subVersion"
+ unless exists $self->{_version};
+ $self->{_language} = $language unless exists $self->{_language};
+ $self->{_script} = $script unless exists $self->{_script};
+ $self->{_suite_count} += $suiteCount;
+
+ for (my $i = 1; $i <= $suiteCount; $i++) {
+ my($flags, %suite);
+ my($suite_name, $suite_description) = $self->_get_paired_string;
+
+ # Get the rest of the suite information
+ my $suiteInfo = $self->_scan(8);
+ my($suiteID, $suiteVersion, $suiteMinor) = unpack("A4 S S", $suiteInfo);
+
+ @suite{qw[_NAME _DESC _ID _VERSION _SIZE
+ _event_list _class_list _comparison_list _enum_list]} = (
+ $suite_name, $suite_description, $suiteID,
+ "$suiteVersion.$suiteMinor", 0
+ );
+
+ # Get the events
+ my $event_count = unpack("S", $self->_scan(2));
+ for (my $i = 1; $i <= $event_count; $i++) {
+ my(%event, %reply, %dobj);
+
+ $event{_param_list} = ();
+ my($event_name, $event_description) = $self->_get_paired_string;
+
+ # Get the rest of the event info
+ @event{qw[_NAME _DESC _CLASS _ID]} = (
+ $event_name, $event_description, $self->_get_ID,
+ $self->_get_ID
+ );
+ @reply{qw[_TYPE _DESC]} = (
+ $self->_get_ID, $self->_get_string
+ );
+
+ $flags = $self->_get_binary;
+ @reply{qw[_REQ _LIST _ENUM]} = (
+ ($flags & 0x8000 ? 0 : 1),
+ ($flags & 0x4000 ? 1 : 0),
+ ($flags & 0x2000 ? 1 : 0)
+ );
+
+ $event{_REPLY} = \%reply;
+
+ # Direct object data
+ @dobj{qw[_TYPE _DESC]} = (
+ $self->_get_ID, $self->_get_string
+ );
+
+ $flags = $self->_get_binary;
+ @dobj{qw[_REQ _LIST _ENUM _CHANGE]} = (
+ ($flags & 0x8000 ? 0 : 1),
+ ($flags & 0x4000 ? 1 : 0),
+ ($flags & 0x2000 ? 1 : 0),
+ ($flags & 0x1000 ? 1 : 0)
+ );
+
+ $event{_DOBJ} = \%dobj;
+
+ # Other parameter data
+ my $other_count = $self->_get_item_count;
+ for (my $i = 1; $i <= $other_count; $i++) {
+ my %param;
+
+ @param{qw[_NAME _ID _TYPE _DESC]} = (
+ $self->_get_string, $self->_get_ID,
+ $self->_get_ID, $self->_get_string
+ );
+
+ $flags = $self->_get_binary;
+ @param{qw[_REQ _LIST _ENUM]} = (
+ ($flags & 0x8000 ? 0 : 1),
+ ($flags & 0x4000 ? 1 : 0),
+ ($flags & 0x2000 ? 1 : 0)
+ );
+
+ push @{$event{_param_list}}, \%param;
+ }
+
+ push @{$suite{_event_list}}, \%event;
+ }
+
+ # Get the classes and properties
+ my $class_count = $self->_get_item_count;
+ for (my $i = 1; $i <= $class_count; $i++) {
+ my %class;
+
+ @class{qw[_NAME _ID _DESC
+ _property_list _element_list]} = (
+ $self->_get_string, $self->_get_ID,
+ $self->_get_string
+ );
+
+ # properties
+ my $property_count = $self->_get_item_count;
+ for (my $i = 1; $i <= $property_count; $i++) {
+ my %property;
+
+ @property{qw[_NAME _ID _CLASS _DESC]} = (
+ $self->_get_string, $self->_get_ID,
+ $self->_get_ID, $self->_get_string
+ );
+
+ $flags = $self->_get_binary;
+ @property{qw[_LIST _ENUM _RDWR]} = (
+ ($flags & 0x4000 ? 1 : 0),
+ ($flags & 0x2000 ? 1 : 0),
+ ($flags & 0x1000 ? 1 : 0)
+ );
+
+ push @{$class{_property_list}}, \%property;
+ }
+
+ # elements
+ my $element_count = $self->_get_item_count;
+ for (my $i = 1; $i <= $element_count; $i++) {
+ my(%element, @kforms);
+
+ $element{_CLASS} = $self->_get_ID;
+ my $kform_count = $self->_get_item_count;
+ for (my $i = 1; $i <= $kform_count; $i++) {
+ push @kforms, $self->_get_ID;
+ }
+ $element{_ID} = \@kforms;
+
+ push @{$class{_element_list}}, \%element;
+ }
+
+ push @{$suite{_class_list}}, \%class;
+ }
+
+ #comparisons
+ my $compare_count = $self->_get_item_count;
+ for (my $i = 1; $i <= $compare_count; $i++) {
+ my %comparison;
+
+ @comparison{qw[_NAME _ID _DESC]} = (
+ $self->_get_string, $self->_get_ID,
+ $self->_get_string
+ );
+
+ push @{$suite{_comparison_list}}, \%comparison;
+ }
+
+ #enumerations
+ my $enum_count = $self->_get_item_count;
+ for (my $i = 1; $i <= $enum_count; $i++) {
+ my %enumeration;
+
+ $enumeration{_ID} = $self->_get_ID;
+ $enumeration{_enum_list} = ();
+ my $eenum_count = $self->_get_item_count;
+ for (my $i = 1; $i <= $eenum_count; $i++) {
+ my %enum;
+
+ @enum{qw[_NAME _ID _COMMENT]} = (
+ $self->_get_string, $self->_get_ID,
+ $self->_get_string
+ );
+
+ push @{$enumeration{_enum_list}}, \%enum;
+ }
+
+ push @{$suite{_enumeration_list}}, \%enumeration;
+ }
+
+ $suite{_SIZE} += $event_count + $class_count +
+ $compare_count + $enum_count;
+ push @{$self->{_suite_list}}, \%suite;
+ }
+ }
+}
+
+
+#
+#############################################################################
+# Private Subroutines #
+#############################################################################
+
+sub _get_binary() {
+ my $self = shift;
+ my $binary = $self->_scan(2);
+ $binary = hex(unpack('H4', $binary));
+}
+
+sub _get_ID() {
+ my $self = shift;
+ my $myID = $self->_scan(4);
+ $myID;
+}
+
+sub _get_item_count() {
+ my $self = shift;
+ my $count = $self->_scan(2);
+ $count = unpack("S", $count);
+}
+
+
+sub _get_string() {
+ my $self = shift;
+ my $length;
+ $length = $self->_scan(1);
+ $length = unpack("C", $length);
+ my $string = $self->_scan($length);
+ # Take care of alignment
+ if ($self->{_handle_index} % 2 == 1) {
+ $self->{_handle_index} += 1;
+ }
+ $string;
+}
+
+sub _get_paired_string() {
+ my $self = shift;
+ my $length;
+ $length = $self->_scan(1);
+ $length = unpack("C", $length);
+ my $string1 = $self->_scan($length);
+ $length = $self->_scan(1);
+ $length = unpack("C", $length);
+ my $string2 = $self->_scan($length);
+ # Take care of alignment
+ if ($self->{_handle_index} % 2 == 1) {
+ $self->{_handle_index} += 1;
+ }
+ ($string1, $string2);
+}
+
+sub _scan {
+ my($self, $byte_count) = @_;
+ my $handle = $self->{_handle};
+ my $result = $handle->get($self->{_handle_index}, $byte_count);
+ $self->{_handle_index} += $byte_count;
+ $result;
+}
+
+1;
+
+__END__
==== //depot/maint-5.6/macperl/macos/lib/Mac/Glue.pm#1 (text) ====
Index: perl/macos/lib/Mac/Glue.pm
--- perl/macos/lib/Mac/Glue.pm.~1~ Wed Oct 3 13:15:05 2001
+++ perl/macos/lib/Mac/Glue.pm Wed Oct 3 13:15:05 2001
@@ -0,0 +1,2152 @@
+package Mac::Glue;
+
+BEGIN {
+ use vars qw($SERIALIZER);
+ $SERIALIZER =
+ $MacPerl::Architecture eq 'MacPPC' ?
+ 'Storable' :
+ $MacPerl::Architecture eq 'MacCFM68K' ?
+ 'FreezeThaw' :
+ die("Must be using CFM68K or PPC build of MacPerl: $MacPerl::Architecture");
+
+}
+
+use Carp;
+use Data::Dumper;
+use Exporter;
+use Fcntl;
+use Mac::AppleEvents::Simple 1.00 ':all';
+use Mac::Apps::Launch 1.70;
+use Mac::Files;
+use Mac::Memory 1.20 ();
+use Mac::Processes 1.01;
+use Mac::Types;
+use MLDBM ('DB_File', $SERIALIZER);
+
+use strict;
+use vars qw(
+ $REVISION $VERSION $AUTOLOAD %AE_PUT %AE_GET @SYMS @METHS
+ @EXPORT @EXPORT_OK %EXPORT_TAGS @ISA $GLUEDIR
+ $GENPKG $GENSEQ %OPENGLUES %MERGEDCLASSES @OTHEREVENT
+ @OTHERCLASS %SPECIALEVENT %SPECIALCLASS %DESCS
+ %MERGEDENUM @OTHERENUM %INSL %DESC_TYPE %COMP %LOGI
+);
+
+#=============================================================================#
+# $Id: Glue.pm,v 1.1 2001/10/03 19:31:55 pudge Exp $
+($REVISION) = ' $Revision: 1.1 $ ' =~ /\$Revision:\s+([^\s]+)/;
+$VERSION = '1.00';
+@ISA = 'Exporter';
+@EXPORT = ();
+@SYMS = qw(
+ obj_form param_type enum whose range location
+ glueTrue glueFalse glueNext gluePrevious
+ glueFirst glueMiddle glueLast glueAny glueAll
+ gTrue gFalse gNext gPrevious
+ gFirst gMiddle gLast gAny gAll
+ );
+@METHS = qw( AUTOLOAD can launch obj prop );
+
+@EXPORT_OK = ( @Mac::AppleEvents::EXPORT, @SYMS );
+%EXPORT_TAGS = (
+ all => [@EXPORT, @EXPORT_OK],
+ glue => [@EXPORT, @SYMS],
+ long => [grep !/^g[A-Z]/, @EXPORT, @SYMS],
+ longall => [grep !/^g[A-Z]/, @EXPORT, @EXPORT_OK],
+ );
+
+$GENPKG = __PACKAGE__;
+$GENSEQ = 0;
+
+# change this if it ever works on other platforms ... Mac OS X?
+$ENV{MACGLUEDIR} ||= "$ENV{MACPERL}site_perl:Mac:Glue:glues:";
+$ENV{MACGLUEDIR} .= ':' unless $ENV{MACGLUEDIR} =~ /:$/;
+
+#=============================================================================#
+# exported functions
+sub obj_form ($$;$) { bless [@_], 'Mac::AEObjDescForm' }
+sub param_type ($$) { bless [@_], 'Mac::AEParamType' }
+sub enum ($) { bless [@_], 'Mac::AEEnum' }
+sub whose { bless [formTest, @_], 'Mac::AEObjDescType' }
+sub range ($$) { bless [formRange, @_], 'Mac::AEObjDescType' }
+sub location ($;$); *location = *_do_loc{CODE};
+
+#=============================================================================#
+# constants
+use constant glueTrue => enum('true');
+use constant glueFalse => enum('false');
+
+use constant glueFirst => obj_form(formAbsolutePosition, typeAbsoluteOrdinal, kAEFirst);
+use constant glueMiddle => obj_form(formAbsolutePosition, typeAbsoluteOrdinal, kAEMiddle);
+use constant glueLast => obj_form(formAbsolutePosition, typeAbsoluteOrdinal, kAELast);
+use constant glueAny => obj_form(formAbsolutePosition, typeAbsoluteOrdinal, kAEAny);
+use constant glueAll => obj_form(formAbsolutePosition, typeAbsoluteOrdinal, kAEAll);
+use constant glueNext => obj_form(formRelativePosition, typeEnumerated, kAENext);
+use constant gluePrevious => obj_form(formRelativePosition, typeEnumerated, kAEPrevious);
+
+use constant glueNull => new AEDesc typeNull;
+
+use constant glueAnd => new AEDesc typeEnumerated, kAEAND;
+use constant glueOr => new AEDesc typeEnumerated, kAEOR;
+use constant glueNot => new AEDesc typeEnumerated, kAENOT;
+
+use constant glueGT => new AEDesc typeEnumerated, kAEGreaterThan;
+use constant glueGE => new AEDesc typeEnumerated, kAEGreaterThanEquals;
+use constant glueEquals => new AEDesc typeEnumerated, kAEEquals;
+use constant glueLT => new AEDesc typeEnumerated, kAELessThan;
+use constant glueLE => new AEDesc typeEnumerated, kAELessThanEquals;
+use constant glueBeginsWith => new AEDesc typeEnumerated, kAEBeginsWith;
+use constant glueEndsWith => new AEDesc typeEnumerated, kAEEndsWith;
+use constant glueContains => new AEDesc typeEnumerated, kAEContains;
+
+
+use constant gTrue => glueTrue();
+use constant gFalse => glueFalse();
+
+use constant gFirst => glueFirst();
+use constant gMiddle => glueMiddle();
+use constant gLast => glueLast();
+use constant gAny => glueAny();
+use constant gAll => glueAll();
+use constant gNext => glueNext();
+use constant gPrevious => gluePrevious();
+
+use constant gNull => glueNull();
+
+use constant gAnd => glueAnd();
+use constant gOr => glueOr();
+use constant gNot => glueNot();
+
+use constant gGT => glueGT();
+use constant gGE => glueGE();
+use constant gEquals => glueEquals();
+use constant gLT => glueLT();
+use constant gLE => glueLE();
+use constant gBeginsWith => glueBeginsWith();
+use constant gEndsWith => glueEndsWith();
+use constant gContains => glueContains();
+
+#=============================================================================#
+_open_others();
+#=============================================================================#
+
+sub new {
+ my($class, $app, $addtype, @add) = @_;
+ my($self, $glue, $db, $app1, $app2);
+
+ # find glue, try a few different names just in case
+ ($app1 = $app) =~ tr/ /_/;
+ ($app2 = $app) =~ tr/_/ /;
+ for (map { "$ENV{MACGLUEDIR}$_" } $app, $app1, $app2) {
+ if (-e) {
+ $glue = $_;
+ last;
+ }
+ }
+ croak "No application glue for '$app' found in '$ENV{MACGLUEDIR}'" unless $glue;
+
+ # if not already opened, open and store reference to db
+ unless (exists $OPENGLUES{$glue}) {
+ tie my %db, 'MLDBM', $glue, O_RDONLY or confess "Can't tie '$glue': $!";
+ $OPENGLUES{$glue} = \%db;
+ }
+ $db = $OPENGLUES{$glue};
+
+ # create new class to put this in, add the symbols we want,
+ # nyah nyah nyah (gosh, I love Perl)
+ $class = $GENPKG . '::GLUE' . $GENSEQ++;
+ {
+ no strict 'refs';
+ for (@METHS) {
+ *{$class . '::' . $_} = *{'Mac::Glue::' . $_}{CODE};
+ }
+ }
+
+ $self = { _DB => $db, ID => $db->{ID}, SWITCH => 0, GLUENAME => $app };
+
+ $self->{ADDRESS} = defined $addtype
+ ? $addtype eq 'ppc' || $addtype eq typeTargetID
+ ? { typeTargetID() => pack_ppc($db->{ID}, @add) }
+
+ : $addtype eq 'eppc' || $addtype eq typeTargetID
+ ? { typeTargetID() => pack_eppc($db->{ID}, @add) }
+
+ : $addtype eq 'psn' || $addtype eq typeProcessSerialNumber
+ ? { typeProcessSerialNumber() => pack_psn($add[0]) }
+
+ : $addtype eq 'path'
+ ? { typeProcessSerialNumber() => _path_to_psn($add[0]) }
+
+ : { $addtype => $add[0] }
+
+ : { typeApplSignature() => $self->{ID} };
+
+ @{$self}{qw(CLASS NAMES IDS)} = _merge_classes($db);
+ _merge_enums($db, $self);
+
+ bless($self, $class);
+}
+
+#=============================================================================#
+# help UNIVERSAL::can out
+
+sub can {
+ my($self, $meth) = @_;
+ return unless @_ == 2;
+ my $can = UNIVERSAL::can($self, $meth);
+ unless ($can) {
+ $AUTOLOAD = ref($self) . '::' . $meth;
+ $can = AUTOLOAD('AUTOLOAD::can', $self);
+ }
+ return $can;
+}
+
+#=============================================================================#
+# define event calls as subs
+
+sub AUTOLOAD {
+ my $can = $_[0] eq 'AUTOLOAD::can' ? shift : 0;
+ my $self = $_[0];
+ (my $name = $AUTOLOAD) =~ s/^.*://;
+ my $sub;
+
+ if ($name eq 'DESTROY') {
+ return;
+ } elsif ($name =~ /^(?:REPLY|SWITCH|MODE|PRIORITY|TIMEOUT|RETOBJ|ERRORS)$/) {
+ $sub = sub { $_[0]->{$name} = $_[1] if $_[1]; $_[0]->{$name} };
+ }
+
+ unless ($sub) {
+ (my $auto = $AUTOLOAD) =~ s/:([^:]+)$/:\L$1/;
+ $sub = $auto if defined &$auto;
+ }
+
+ unless ($sub) {
+ if (my $event = _find_event($self, lc $name)) {
+ $sub = sub { _primary($_[0], $event, lc $name, @_[1 .. $#_]) }
+ } elsif (! $can) {
+ croak "No event '$name' available from glue for '$self->{GLUENAME}'";
+ }
+ }
+
+ # install new sub, only do AUTOLOAD for it once!
+ if ($sub) {
+ no strict 'refs';
+ *{$AUTOLOAD} = $sub;
+ }
+
+ return $sub if $can;
+ goto &$sub;
+}
+
+#=============================================================================#
+# login using GTQ Login As OSAX
+# will NOT return error if exists, because MacPerl does not handle replies well
+
+sub login {
+ my($self, $user, $pass) = @_;
+
+ my $evt = build_event(qw(gtqp lgin McPL), q{'----':TEXT(@), pwrd:TEXT(@)},
+ $user, $pass);
+ $evt->send_event(kAENoReply);
+
+ return 1;
+}
+
+#=============================================================================#
+# basic subroutine building and sending every event call
+# (see sub AUTOLOAD)
+
+sub _primary {
+ my($self, $e, $name, @args) = @_;
+ my($evt, %xargs, $dobj, @origargs);
+
+ my($class, $event, $reply, $params) = @{$e}{qw(class event reply params)};
+
+ $dobj = shift @args if @args % 2;
+
+ %xargs = @args;
+ for (keys %xargs) {
+ delete $xargs{$_} unless /^(?:CALLBACK|CLBK_ARG)$/;
+ }
+ @xargs{keys %{$self->{ADDRESS}}} = values %{$self->{ADDRESS}};
+
+ # create event (Mac::AppleEvents::Simple object)
+ $evt = build_event($class, $event, \%xargs);
+
+ # prepare parameters (direct object)
+ if (defined $dobj) {
+ croak "Direct object parameter not present"
+ unless exists $params->{keyDirectObject()};
+ _params($self, $evt, $params->{keyDirectObject()}, $dobj);
+ push @origargs, 'DOBJ', $dobj;
+ }
+
+ # prepare parameters (all the rest)
+ my $hash = {@args};
+ if ($hash) {
+ for my $p (keys %$hash) {
+ next if $p =~ /^(?:REPLY|SWITCH|MODE|PRIORITY|TIMEOUT|RETOBJ|ERRORS|CALLBACK|CLBK_ARG)$/;
+ my $pp = $p eq 'DOBJ' ? keyDirectObject : lc $p;
+ croak "'$p' parameter not available" unless exists $params->{$pp};
+ _params($self, $evt, $params->{$pp}, $hash->{$p});
+ push @origargs, $pp, $p;
+ }
+ }
+
+ # prepare send parameters and send event
+ local $Mac::AppleEvents::Simple::SWITCH =
+ $hash->{SWITCH} ? $hash->{SWITCH} : $self->{SWITCH};
+
+ # we'll wait if REPLY not set and TIMEOUT is set
+ if (!exists $hash->{REPLY} && exists $hash->{TIMEOUT}) {
+ $self->{REPLY} = 1;
+ }
+
+ my $mode =
+ (ref $hash->{CALLBACK} eq 'CODE'
+ ? kAEQueueReply
+ : (exists $hash->{REPLY} # check event setting
+ ? $hash->{REPLY}
+ : exists $self->{REPLY} # check global setting
+ ? $self->{REPLY}
+ : 1 # default to wait
+ )
+ ? kAEWaitReply
+ : kAENoReply)
+
+ | (exists $hash->{MODE}
+ ? $hash->{MODE}
+ : exists $self->{MODE}
+ ? $self->{MODE}
+ : (kAECanInteract | kAECanSwitchLayer));
+
+ my $priority =
+ exists $hash->{PRIORITY}
+ ? $hash->{PRIORITY}
+ : exists $self->{PRIORITY}
+ ? $self->{PRIORITY}
+ : kAENormalPriority;
+
+ my $timeout =
+ exists $hash->{TIMEOUT}
+ ? 60 * $hash->{TIMEOUT} # convert seconds to ticks
+ : exists $self->{TIMEOUT}
+ ? 60 * $self->{TIMEOUT}
+ : kNoTimeOut;
+
+ $evt->send_event($mode, $priority, $timeout);
+
+ my $retobj = exists $hash->{RETOBJ}
+ ? $hash->{RETOBJ}
+ : exists $self->{RETOBJ}
+ ? $self->{RETOBJ}
+ : 0;
+
+ my $error_handler = exists $hash->{ERRORS}
+ ? $hash->{ERRORS}
+ : exists $self->{ERRORS}
+ ? $self->{ERRORS}
+ : 0;
+
+ local $AE_GET{typeObjectSpecifier()} = sub {
+ return(_obj_desc($self, $_[0]), 1);
+ };
+
+ local $Mac::AppleEvents::Simple::CLASSREC = sub {
+ return _is_class($self, $_[0]);
+ };
+
+ local $Mac::AppleEvents::Simple::ENUMREC = sub {
+ return _is_enum($self, $_[0]);
+ };
+
+ my @return;
+ if ($retobj) {
+ @return = $evt;
+ } elsif (my $type = $evt->type) {
+ @return = $evt->get;
+ @return = _fix_reco($self, {@return}) if $type eq typeAERecord;
+ @return = @{_fix_reco($self, \@return)} if $type eq typeAEList;
+ }
+
+ $^E = exists $evt->{ERRNO} ? $evt->{ERRNO} : 0; # restore errno
+
+ my $return = 1;
+ # if error handler, only return if error handler returns true
+ # what should error handler be passed?
+ if ($^E && $error_handler) {
+ my($package, $filename, $line) = caller(1);
+ $return = $error_handler->({
+ _glue => $self,
+ _event => $evt,
+ glue => $self->{GLUENAME},
+ event => $name,
+ errs => $^E,
+ errn => $^E+0,
+ line => $line,
+ 'package' => $package,
+ filename => $filename,
+ }, @origargs);
+ }
+
+ return(wantarray ? @return : $return[0]) if $return;
+}
+
+#=============================================================================#
+# prepare all event parameters
+
+sub _params {
+ my($self, $evt, $p, $data) = @_;
+ my($key, $type) = @{$p}[0, 1];
+
+ if (ref $data eq 'Mac::AEParamType') {
+ ($data, $type) = @{$data}[1, 0];
+ } elsif ($type eq typeObjectSpecifier && ref $data ne 'Mac::AEObjDesc') {
+ $type = $data =~ /^[+-]?\d+$/ ? typeInteger : typeChar;
+ }
+
+ my($desc, $dispose) = _get_desc($self, $data, $type);
+ AEPutParamDesc($evt->{EVT}, $key, $desc)
+ or confess "Can't put $key/$desc into event: $^E";
+ AEDisposeDesc $desc if $dispose;
+}
+
+#=============================================================================#
+# Put anon array parameter data into AE list
+
+sub _do_list {
+ my($self, $data, $type) = @_;
+ my $list = AECreateList('', 0) or confess "Can't create list: $^E";
+ my $count = 0;
+
+ for my $d (@{$data}) {
+ my($desc, $dispose) = _get_desc($self, $d);
+ AEPutDesc($list, ++$count, $desc)
+ or confess "Can't put $desc into $list: $^E";
+ AEDisposeDesc $desc if $dispose;
+ }
+
+ return $list;
+}
+
+#=============================================================================#
+# Put anon hash parameter data into AE record
+
+sub _do_rec {
+ my($self, $data, $type) = @_;
+ my $reco = AECreateList('', 1) or confess "Can't create record: $^E";
+ my $class;
+
+ while (my($k, $d) = each %{$data}) {
+ if ($k =~ /^class$/i) {
+ $class = _get_id($self, $d);
+ next;
+ }
+ my $key = _get_id($self, $k);
+ my($desc, $dispose) = _get_desc($self, $d);
+ AEPutKeyDesc($reco, $key, $desc)
+ or confess "Can't put $key/$desc into $reco: $^E";
+ AEDisposeDesc $desc if $dispose;
+ }
+
+ if ($class) {
+ my $nreco = AECoerceDesc($reco, $class)
+ or confess "Can't coerce to '$class': $^E";
+ AEDisposeDesc $reco;
+ $reco = $nreco;
+ }
+
+ return $reco;
+}
+
+#=============================================================================#
+# create AE descriptor record
+
+sub _do_obj {
+ my($self, $data, $class, $from) = @_;
+ my($list, $obj, $form, $dataform, $d, $ref);
+ $class = 'property' if $class =~ /^(?:of|in|prop)$/;
+ confess "Class '$class' does not exist for '$data'.\n"
+ unless exists $self->{NAMES}{$class};
+
+ $data = _get_objdesc($data);
+ $ref = ref $data;
+
+ if ($class eq 'property') {
+ $data = _get_id($self, $data) or croak "Can't find property '$data'.\n";
+ $form = typeProperty;
+
+ } elsif ($ref eq 'AEDesc' || $ref eq 'Mac::AEObjDescType') {
+ $data = $DESC_TYPE{$data->[0]}->($self, $class, @{$data}[1 .. $#{$data}])
+ if $ref eq 'Mac::AEObjDescType';
+ $dataform = $form = $data->type;
+ if ($form eq typeCompDescriptor || $form eq typeLogicalDescriptor) {
+ $form = formTest;
+ }
+
+ } elsif ($ref eq 'Mac::AEObjDescForm') {
+ $form = $$data[0];
+ $dataform = $$data[1] if @$data == 3;
+ $data = $$data[-1];
+
+ } elsif ($data =~ /^[+-]?\d+$/) {
+ $form = formAbsolutePosition;
+
+ } else {
+ $form = formName;
+ }
+
+ $dataform ||=
+ $form eq formName ? typeChar :
+ $form eq formAbsolutePosition ? typeInteger :
+ $form eq typeProperty ? typeType :
+ $form;
+
+ $class = $self->{NAMES}{$class};
+ $list = AECreateList('', 1) or confess "Can't create list: $^E";
+
+ # form / keyAEForm
+ AEPutKey($list, keyAEForm, typeEnumerated, $form)
+ or confess "Can't put form:$form into object: $^E";
+
+ # want / keyAEDesiredClass
+ AEPutKey($list, keyAEDesiredClass, typeType, $class->{id})
+ or confess "Can't put want:$class->{id} into object: $^E";
+
+ # seld / keyAEKeyData
+ ($d, $dataform) = _get_data($self, $data, $dataform);
+ if (ref $d eq 'AEDesc') {
+ AEPutKeyDesc($list, keyAEKeyData, $d)
+ or confess "Can't put seld:$d into object: $^E";
+ } else {
+ AEPutKey($list, keyAEKeyData, $dataform, $d)
+ or confess "Can't put seld:$dataform($d) into object: $^E";
+ }
+
+ # type / keyAEContainer
+ if ($from && $from eq typeCurrentContainer) {
+ AEPutKey($list, keyAEContainer, $from, '')
+ or confess "Can't put from:$from into object: $^E";
+ } elsif ($from && $from eq typeObjectBeingExamined) {
+ AEPutKey($list, keyAEContainer, $from, '')
+ or confess "Can't put from:$from into object: $^E";
+ } elsif ($from) {
+ $from = _get_objdesc($from);
+ AEPutKeyDesc($list, keyAEContainer, $from)
+ or confess "Can't put from:$from into object: $^E";
+ } else {
+ AEPutKey($list, keyAEContainer, typeNull, '')
+ or confess "Can't put from:null into object: $^E";
+ }
+
+ $obj = AECoerceDesc($list, typeObjectSpecifier)
+ or confess "Can't coerce to 'obj ': $^E";
+ AEDisposeDesc $list;
+
+ return _obj_desc($self, $obj);
+}
+
+#=============================================================================#
+# create insertion record
+
+sub _do_loc ($;$) {
+ my($pos, $obj) = @_;
+ $obj = _get_objdesc($obj);
+ my $desc = ref $obj eq 'AEDesc' ? $obj : gNull();
+ my $list = AECreateList('', 1) or confess "Can't create list: $^E";
+
+ AEPutKeyDesc($list, keyAEObject, $desc)
+ or confess "Can't put object in location: $^E";
+ AEPutKey($list, keyAEPosition, typeEnumerated, $INSL{$pos} || $pos)
+ or confess "Can't put pos in location: $^E";
+
+ my $insl = AECoerceDesc($list, typeInsertionLoc)
+ or confess "Can't coerce $list to 'obj ': $^E";
+ AEDisposeDesc $list;
+ _save_desc($insl);
+ return $insl;
+}
+
+#=============================================================================#
+# create glue descriptor record
+
+sub _do_range {
+ my($self, $class, $r1, $r2) = @_;
+
+ $r1 = _do_obj($self, $r1, $class, typeCurrentContainer);
+ $r2 = _do_obj($self, $r2, $class, typeCurrentContainer);
+
+ my $list = AECreateList('', 1) or confess "Can't create list: $^E";
+
+ AEPutKeyDesc($list, keyAERangeStart, $r1->{DESC})
+ or confess "Can't add param to list: $^E";
+ AEPutKeyDesc($list, keyAERangeStop, $r2->{DESC})
+ or confess "Can't add param to list: $^E";
+
+ my $rang = AECoerceDesc($list, typeRangeDescriptor)
+ or confess "Can't coerce to range: $^E";
+ AEDisposeDesc $list;
+ _save_desc($rang);
+
+ return $rang;
+}
+
+#=============================================================================#
+# create comparison descriptor record
+
+sub _do_comp {
+ my $self = shift;
+ my $len = @_;
+ my($p1, $d1, $op, $p2, $d2, $c1, $c2, $dispose1, $dispose2);
+
+ $p1 = $len < 4 ? 'property' : shift;
+ $d1 = shift;
+ $op = shift;
+ $p2 = $len < 5 ? undef : shift;
+ $d2 = shift;
+
+ unless (ref $op eq 'AEDesc') {
+ my $foo = $op;
+ $op = $COMP{lc $op} or croak "Comparison operator '$foo' not recognized";
+ }
+
+ if ($p1 eq 'property' && $d1 eq 'it') {
+ $c1 = new AEDesc typeObjectBeingExamined;
+ $dispose1 = 1;
+ } else {
+ $c1 = _do_obj($self, $d1, $p1, typeObjectBeingExamined)->{DESC};
+ }
+
+ if (defined $p2) {
+ $c2 = _do_obj($self, $d2, $p2, typeObjectBeingExamined)->{DESC};
+ } else {
+ ($c2, $dispose2) = _get_desc($self, $d2);
+ }
+
+ my $list = AECreateList('', 1) or confess "Can't create list: $^E";
+
+ AEPutKeyDesc($list, keyAECompOperator, $op);
+ AEPutKeyDesc($list, keyAEObject1, $c1);
+ AEPutKeyDesc($list, keyAEObject2, $c2);
+
+ AEDisposeDesc $c1 if $dispose1;
+ AEDisposeDesc $c2 if $dispose2;
+
+ my $comp = AECoerceDesc($list, typeCompDescriptor)
+ or confess "Can't coerce list to comparison descriptor: $^E";
+ AEDisposeDesc $list;
+ _save_desc($comp);
+
+ return $comp;
+}
+
+#=============================================================================#
+# create a logical descriptor record
+
+sub _do_logical {
+ my($self, $op, @args) = @_;
+ my $terms = AECreateList('', 0) or confess "Can't create list: $^E";
+
+ unless (ref $op eq 'AEDesc') {
+ my $foo = $op;
+ $op = $LOGI{uc $op} or croak "Logical operator '$foo' not recognized";
+ }
+
+ for my $i (0 .. $#args) {
+ my $term = $args[$i];
+ my $desc;
+ croak "Each logical term must be in an anonymous array ($term)\n"
+ if ref $term ne 'ARRAY';
+
+ if (grep { ref ne 'ARRAY' } @{$term}[1 .. $#{$term}]) {
+ $desc = _do_comp($self, @$term);
+ } else {
+ $desc = _do_logical($self, @$term);
+ }
+ AEPutDesc($terms, $i + 1, $desc);
+ }
+
+ my $list = AECreateList('', 1) or confess "Can't create list: $^E";
+ AEPutKeyDesc($list, keyAELogicalOperator, $op);
+ AEPutKeyDesc($list, keyAELogicalTerms, $terms);
+
+ my $logi = AECoerceDesc($list, typeLogicalDescriptor)
+ or confess "Can't coerce list into logical descriptor: $^E";
+ AEDisposeDesc $terms;
+ AEDisposeDesc $list;
+ _save_desc($logi);
+
+ return $logi;
+}
+
+#=============================================================================#
+# help create a test object record
+
+sub _do_whose {
+ splice @_, 1, 1; # remove class
+ if (grep { ref ne 'ARRAY' } @_[2 .. $#_]) {
+ goto &_do_comp;
+ } else {
+ goto &_do_logical;
+ }
+}
+
+#=============================================================================#
+# return descriptor as needed
+
+sub _get_desc {
+ my($self, $data, $type) = @_;
+ my($desc, $dispose, $ref);
+
+ $dispose = 1;
+ $data = _get_objdesc($data);
+ $ref = ref $data;
+
+ if ($ref eq 'ARRAY') {
+ $desc = _do_list($self, $data, $type);
+ } elsif ($ref eq 'HASH') {
+ $desc = _do_rec($self, $data, $type);
+ } elsif ($ref eq 'AEDesc') {
+ $desc = $data;
+ $dispose = 0;
+ _save_desc($desc);
+ } else {
+ my($d, $t);
+ $t = _get_type($self, $data, $type);
+ ($d, $t) = _get_data($self, $data, $t);
+
+ if (ref $d eq 'AEDesc') {
+ $desc = $d;
+ $dispose = 0;
+ _save_desc($d);
+ } else {
+ $desc = AEDesc->new($t, $d);
+ }
+ }
+
+ return($desc, $dispose);
+}
+
+#=============================================================================#
+# take a good guess at what the data type is
+
+sub _get_type {
+ my($self, $data, $type, $key) = @_;
+ my $i = 0;
+
+ if (defined $key) {
+ my $href = _get_id($self, $key, 1);
+ $type = $href->{types}[$i++] if exists $href->{types};
+ }
+
+ if (!$type || $type eq typeWildCard) {
+ $type = $data =~ /^[+-]?\d+$/ ? typeInteger : typeChar;
+ }
+
+ return $type;
+}
+
+#=============================================================================#
+# fudge the data into something that the event will be expecting
+# should only return data as simple non-reference scalar or AEDesc
+
+sub _get_data {
+ my($self, $data, $type) = @_;
+ my $t;
+
+ my $ref = ref $data;
+
+ if ($ref eq 'Mac::AEEnum') {
+ my $id = _get_id($self, $data->[0]);
+ $data = $id if defined $id;
+ $type = typeEnumerated; # typeEnumerated or typeType ???
+
+ } elsif ($type eq typeType) {
+ my $id = _get_id($self, $data);
+ $data = $id if defined $id;
+
+ # see the %AE_PUT data structure
+ } elsif (exists $AE_PUT{$type}) {
+ ($data, $t) = $AE_PUT{$type}->($data);
+ }
+
+ return($data, $t || $type);
+}
+
+#=============================================================================#
+# get class / property name
+
+sub _get_name {
+ my($self, $id) = @_;
+ if (exists $self->{IDS}{$id}) {
+ if (exists $self->{IDS}{$id}{name}) {
+ return $self->{IDS}{$id}{name};
+ }
+ }
+ return;
+}
+
+#=============================================================================#
+# find if ID is class
+
+sub _is_class {
+ my($self, $id) = @_;
+ my $name = _get_name($self, $id) or return;
+ my $class = $self->{CLASS}{$name} or return;
+ if (scalar keys %{$class->{properties}} > 1 ||
+ (scalar keys %{$class->{properties}} == 1 && ! exists $class->{properties}{''})) {
+# print Dumper $class->{properties};
+ return 1;
+ }
+}
+
+#=============================================================================#
+# return name if type is enum
+
+sub _is_enum {
+ my($self, $id) = @_;
+ return unless exists $self->{ENUM}{$id};
+ return _get_name($self, $id);
+}
+
+#=============================================================================#
+# fix record stuff
+
+sub _fix_reco {
+ my($self, $data) = @_;
+
+ if (ref $data eq 'ARRAY') {
+ my @narr;
+ for my $i (@$data) {
+ push @narr, (ref $i eq 'HASH' || ref $i eq 'ARRAY')
+ ? _fix_reco($self, $i) : $i;
+ }
+ return \@narr;
+ } elsif (ref $data eq 'HASH') {
+ my %nreco;
+ for my $id (keys %$data) {
+ my $nid = _get_name($self, $id);
+ my $i = $data->{$id};
+ $nreco{$nid || $id} = (ref $i eq 'HASH' || ref $i eq 'ARRAY')
+ ? _fix_reco($self, $i) : $i;
+ }
+ return \%nreco;
+ }
+}
+
+#=============================================================================#
+# get class / property id
+
+sub _get_id {
+ my($self, $name, $obj) = @_;
+ (my $new = lc $name) =~ tr/ /_/;
+ my $ref = $self->{NAMES}{$new} if exists $self->{NAMES}{$new};
+ return $obj ? $ref : $ref->{id};
+}
+
+#=============================================================================#
+# get Mac::AEObjDesc
+
+sub _get_objdesc {
+ my $ref = ref $_[0];
+ if ($ref eq 'Mac::AEObjDesc') {
+ return $_[0]->{DESC};
+ } else {
+ return $_[0];
+ }
+}
+
+#=============================================================================#
+# create Mac::AEObjDesc
+
+sub _obj_desc {
+ _save_desc($_[1]);
+ my $self = bless { GLUE => $_[0], DESC => $_[1] }, 'Mac::AEObjDesc';
+}
+
+#=============================================================================#
+# save AEDesc for destruction later in Mac::AppleEvents::Simple
+
+sub _save_desc { $DESCS{$_[0]} = $_[0] }
+
+#=============================================================================#
+# find all information for an event, based on its "name"
+
+sub _find_event {
+ my($self, $name) = @_;
+ my $event;
+
+ return $SPECIALEVENT{$name} if exists $SPECIALEVENT{$name};
+
+ for ($self->{_DB}{EVENT}, @OTHEREVENT) {
+ if (exists $_->{$name}) {
+ $event = $_->{$name};
+ last;
+ }
+ }
+
+ return $event;
+}
+
+#=============================================================================#
+# is class a plural of another?
+
+sub _is_plural {
+ my($self, $class) = @_;
+ my $pl = 'c@#!';
+ return unless exists $self->{CLASS}{$class}{properties};
+ my $pref = $self->{CLASS}{$class}{properties};
+ return scalar grep { $pref->{$_}[0] && $pref->{$_}[0] eq $pl } keys %$pref;
+}
+
+#=============================================================================#
+# create an AE object
+
+sub prop {
+ @_ = ($_[0], 'property', @_[1 .. $#_]);
+ goto &obj;
+}
+
+sub obj {
+ my($self, @data, $obj, @obj) = @_;
+
+ if (ref($data[-1]) =~ /^(Mac::)?AE(?:Obj)?Desc$/) { # @data % 2 &&
+ $obj = pop @data;
+ }
+
+ for (my $i = 0; $i <= $#data; $i++) {
+ my($k, $v) = $data[$i];
+ if (!(
+ $data[$i+1]
+ &&
+ ref($data[$i+1]) =~ /^(Mac::)?AE/)
+ &&
+ _is_plural($self, $k)
+ ) {
+ $v = gAll();
+ } else {
+ $i++;
+ $v = $data[$i];
+ }
+ push @obj, [$v, $k];
+ }
+
+ for (reverse @obj) {
+ local $^W;
+ $obj = _do_obj($self, @{$_}[0, 1], $obj);
+ }
+
+ return $obj;
+}
+
+#=============================================================================#
+# launch the app (done automatically when an event is called if not running)
+
+sub launch {
+ my($self, $location) = @_;
+ if (defined $location) {
+ LaunchSpecs($location);
+ } else {
+ LaunchApps($self->{ID});
+ }
+}
+
+#=============================================================================#
+# launch spec and then get PSN
+
+sub _path_to_psn {
+ my($path) = @_;
+
+ confess "Path '$path' does not exist" unless -e $path;
+
+ my $lp = LaunchParam->new(
+ launchControlFlags => (launchContinue | launchNoFileFlags | launchDontSwitch),
+ launchAppSpec => $path
+ );
+
+ my $psn = LaunchApplication($lp) or confess "Cannot launch '$path': $^E";
+
+ return pack_psn($psn);
+}
+
+#=============================================================================#
+# open scripting additions and dialect files only once,
+# save them for further use by all Mac::Glue instances
+
+sub _open_others {
+ chomp(my $curdir = `pwd`);
+ my @others;
+ for my $dir (map { "$ENV{MACGLUEDIR}$_" } qw[dialects additions]) {
+ unless (-e $dir) {
+ warn "Please run gluedialect and gluescriptadds programs."
+ unless $Mac::Glue::CREATINGGLUES;
+ next;
+ }
+
+ local *DIR;
+ opendir DIR, $dir or confess "Can't open directory '$dir': $!";
+ chdir $dir or confess "Can't chdir directory '$dir': $!";
+
+ # ### add file type / creator checking
+ for (readdir DIR) {
+ next if $_ eq "Icon\015";
+ next if /\.pod$/;
+ tie my %db, 'MLDBM', $_, O_RDONLY or confess "Can't tie '$_': $!";
+ push @OTHEREVENT, $db{EVENT} if $db{EVENT};
+ push @OTHERCLASS, $db{CLASS} if $db{CLASS};
+ push @OTHERENUM, $db{ENUM} if $db{ENUM};
+ }
+ }
+ chdir $curdir or confess "Can't chdir to '$curdir': $!";
+}
+
+#=============================================================================#
+# merge additions, dialect, and glue classes together
+
+sub _merge_classes {
+ my($db) = @_;
+ if (!exists $MERGEDCLASSES{ $db->{ID} }) {
+ my($ids, $names) = ({}, {});
+ my($class, @classes) = ($db->{CLASS}, @OTHERCLASS);
+
+ for my $c (keys %$class) {
+ $names->{$c}{id} = $class->{$c}{id};
+ $ids->{$names->{$c}{id}}{name} = $c;
+
+ for my $p (keys %{$class->{$c}{properties}}) {
+ $names->{$p}{id} ||= $class->{$c}{properties}{$p}[0];
+ $ids->{$names->{$p}{id}}{name} ||= $p;
+ unshift @{$names->{$p}{types}}, $class->{$c}{properties}{$p}[1];
+ }
+ }
+
+ for my $tempc (@classes) {
+ for my $c (keys %$tempc) {
+ $names->{$c}{id} ||= $tempc->{$c}{id};
+ $ids->{$names->{$c}{id}}{name} = $c;
+
+ for my $p (keys %{$tempc->{$c}{properties}}) {
+ $names->{$p}{id} ||= $tempc->{$c}{properties}{$p}[0];
+ $ids->{$names->{$p}{id}}{name} ||= $p;
+ unshift @{$names->{$p}{types}}, $tempc->{$c}{properties}{$p}[1];
+
+ $class->{$c}{properties}{$p} = $tempc->{$c}{properties}{$p}
+ if (exists $class->{$c} &&
+ $class->{$c}{id} eq $tempc->{$c}{id} &&
+ ! exists $class->{$c}{properties}{$p});
+ }
+
+ unless (exists $class->{$c}) {
+ $class->{$c} = $tempc->{$c};
+ }
+ }
+ }
+
+ $MERGEDCLASSES{ $db->{ID} } = [$class, $names, $ids];
+ }
+ return @{$MERGEDCLASSES{ $db->{ID} }};
+}
+
+#=============================================================================#
+# "merge" additions, dialect, and glue enumerations together
+
+sub _merge_enums {
+ my($db, $self) = @_;
+ if (!exists $MERGEDENUM{ $db->{ID} }) {
+ my $names = $self->{NAMES};
+ my $ids = $self->{IDS};
+
+ for my $tempc (grep defined, $db->{ENUM}, @OTHERENUM) {
+ for my $c (keys %$tempc) {
+ $self->{ENUMTYPE}{$c} = [];
+ for my $n (keys %{$tempc->{$c}}) {
+ $names->{$n}{id} ||= $tempc->{$c}{$n}{id};
+ $ids->{$names->{$n}{id}} ||= { name => $n };
+ $self->{ENUM}{$tempc->{$c}{$n}{id}} = 1;
+ push @{$self->{ENUMTYPE}{$c}}, $tempc->{$c}{$n}{id};
+ }
+ }
+ }
+ $MERGEDENUM{ $db->{ID} }++;
+ }
+ $MERGEDENUM{ $db->{ID} };
+}
+
+#=============================================================================#
+
+*AE_GET = *Mac::AppleEvents::Simple::AE_GET{HASH};
+*DESCS = *Mac::AppleEvents::Simple::DESCS{HASH};
+
+%INSL = (
+ end => kAEEnd,
+ before => kAEBefore,
+ beginning => kAEBeginning,
+ front => kAEBeginning,
+ after => kAEAfter,
+ back => kAEAfter,
+ behind => kAEAfter,
+);
+
+%COMP = (
+ g_t => gGT(),
+ g_e => gGE(),
+ equals => gEquals(),
+ l_t => gLT(),
+ l_e => gLE(),
+ begins_with => gBeginsWith(),
+ ends_with => gEndsWith(),
+ contains => gContains(),
+);
+
+%LOGI = (
+ AND => gAnd(),
+ OR => gOr(),
+ NOT => gNot(),
+);
+
+%AE_PUT = (
+ typeShortInteger() => sub {MacPack(typeShortInteger, $_[0])},
+ typeInteger() => sub {MacPack(typeInteger, $_[0])},
+ typeBoolean() => sub {MacPack(typeBoolean, $_[0])},
+ typeChar() => sub {MacPack(typeChar, $_[0])},
+ typeFSS() => sub {MacPack(typeFSS, $_[0])},
+ typeAlias() => sub {
+ my $alis = NewAliasMinimalFromFullPath($_[0])
+ or croak "Can't create alias for '$_[0]': $^E";
+ return $alis->get;
+ },
+ typeWildCard() => sub {
+ my $type = _get_type('', $_[0], typeWildCard);
+ my $data = _get_data('', $_[0], $type);
+ return($data, $type);
+ },
+ typeProcessSerialNumber() => sub { pack_psn($_[0]) },
+
+ # just a guess here ... empty four bytes for lang code, maybe?
+ 'itxt' => sub {' ' . MacPack(typeChar, $_[0])},
+);
+
+%DESC_TYPE = (
+ formRange() => \&_do_range,
+ formTest() => \&_do_whose,
+);
+
+%SPECIALEVENT = (
+ 'set' => {
+ 'class' => 'core',
+ 'event' => 'setd',
+ 'reply' => ['****', 0, 0, 0],
+ 'params' => {
+ '----' => [keyDirectObject, 'obj ', 1, 0, 0, 1],
+ 'to' => ['data', '****', 1, 0, 0],
+ }
+ },
+ 'get' => {
+ 'class' => 'core',
+ 'event' => 'getd',
+ 'reply' => ['****', 1, 0, 0],
+ 'params' => {
+ '----' => [keyDirectObject, 'obj ', 1, 0, 0, 0],
+ 'as' => ['rtyp', 'type', 0, 1, 0],
+ }
+ },
+);
+
+%SPECIALCLASS = (
+
+);
+
+#=============================================================================#
+# other glue* stuff
+for (gNull(), gAnd(), gOr(), gNot(), gGT(), gGE(), gEquals(),
+ gLT(), gLE(), gBeginsWith(), gEndsWith(), gContains()) {
+ _save_desc($_);
+}
+
+#=============================================================================#
+
+1;
+
+__END__
+
+=head1 NAME
+
+Mac::Glue - Control Mac apps with Apple event terminology
+
+=head1 SYNOPSIS
+
+ use Mac::Glue;
+ my $glue = Mac::Glue->new('Finder');
+ $glue->open( $glue->prop('System Folder') );
+ # see rest of docs for lots more info
+
+=head1 DESCRIPTION
+
+"Mac::Glue does AppleScript so you don't have to."
+
+You should have the latest cpan-mac distribution:
+
+ http://sourceforge.net/projects/cpan-mac/
+
+For more information, support, CVS, etc.:
+
+ http://sourceforge.net/projects/mac-glue/
+
+Mac OS apps speak to each other with a I<lingua franca> called B<Apple
+events>. The most common way to do Apple events (aside from doaing them
+in a precompiled application with C, Pascal, etc.) is with
+AppleScript. Other languages can do Apple events too, like Frontier and
+even Python. But we like Perl.
+
+MacPerl has for a few years had an interface to Apple events, with the
+Mac::AppleEvents module, which is the basis for everything we'll do
+here. Mac::AppleEvents::Simple was made to simplify the process of
+doing Apple events in MacPerl, but even that can be too much trouble to
+use. One has to find out the class and event IDs, find out the keywords
+and data types for each parameter, etc.
+
+So the vision was born for a framework that wouldn't take much
+significant work. An application's AETE resource would provide the
+names to match to the cryptic four-character codes we had been using.
+Compare.
+
+=over 4
+
+=item Raw Mac::AppleEvents method
+
+ use Mac::AppleEvents;
+ $evt = AEBuildAppleEvent('aevt', 'odoc', typeApplSignature, 'MACS',
+ kAutoGenerateReturnID, kAnyTransactionID,
+ "'----': obj{want:type(prop), from:'null'()," .
+ "form:prop, seld:type(macs)}"
+ ) or die $^E;
+ $rep = AESend($evt, kAEWaitReply) or die $^E;
+ AEDisposeDesc($evt);
+ AEDisposeDesc($rep);
+
+=item Easier Mac::AppleEvents::Simple method
+
+ use Mac::AppleEvents::Simple;
+ do_event(qw(aevt odoc MACS),
+ "'----': obj{want:type(prop), from:'null'()," .
+ "form:prop, seld:type(macs)}"
+ );
+
+=item Cool Mac::Glue method
+
+ use Mac::Glue;
+ my $glue = Mac::Glue->new('Finder');
+ $glue->open( $glue->prop('System Folder') );
+
+=back
+
+The latter is much simpler to understand, to read, to write. It
+leverages the user's understanding of AppleScript. And it is just more
+natural.
+
+There are downsides. Mac::Glue is less powerful than the
+Mac::AppleEvents raw interfaces, because it offers less flexibility
+in how events are called. It is also slower to start a script,
+because the glue structures need to be loaded in. However, once a
+script has started, a difference in speed from the raw interfaces should
+be minimal (though not a lot of testing has been done on that). With the
+code above, on a PowerBook G3/292, running Mac OS 8.6:
+
+ Benchmark: timing 100 iterations of glue, glue2, raw, simple...
+ glue: 10 secs ( 9.98 usr 0.00 sys = 9.98 cpu)
+ glue2: 8 secs ( 8.35 usr 0.00 sys = 8.35 cpu)
+ raw: 8 secs ( 7.88 usr 0.00 sys = 7.88 cpu)
+ simple: 7 secs ( 7.50 usr 0.00 sys = 7.50 cpu)
+
+The "glue2" entry is the same as "glue" entry, but it creates a glue
+object only once instead of each time through, cutting down on the
+overhead. It appears that Mac::Glue is a bit slower than the other
+methods, but not substantially, and it is cooler and easier.
+The one place where performance is the biggest problem is on
+initial execution of the program, but once it starts it is plenty fast.
+We'll work to cut down that start time, too.
+
+So, now that you are convinced this is cool, let's continue.
+
+=head2 Creating a Glue
+
+In order to script an application with Mac::Glue, a glue must be created
+first. For that, the application is dropped on the F<gluemac> droplet.
+A distribution called Mac::AETE, created by David Schooley, is used to
+parse an application's AETE resource, and the glue is written out to a
+file using Storable, DB_File, and MLDBM. Glues are saved in
+$ENV{MACGLUEDIR} (which is defined when Mac::Glue is used if it is not
+defined already). By default, glues are stored in
+F<:site_perl:Mac:Glue:glues:>.
+
+All glues have access to the global scripting additions and dialect
+information. Glues for these must be created as well, and are created
+with the F<gluescriptadds> and F<gluedialect> programs, which are
+similar to the F<gluemac> program. They are saved in
+"$ENV{MACGLUEDIR}additions:" and "$ENV{MACGLUEDIR}dialects:".
+
+Along with the glue file is a POD file containing documentation for the
+glue, listing all the events (with parameters), classes (with
+properties), and enumerators, and descriptions of each.
+
+
+=head2 Using a Glue
+
+The first thing you do is call the module.
+
+ use Mac::Glue;
+
+Then you create an object for your app by passing the C<new> function
+the name of the glue (you may include or omit underscores in the name if
+you like).
+
+ my $glue = Mac::Glue->new('My App'); # or My_App
+
+You can also pass in additional parameters for the type of target to use.
+For PPC ports, you can do this:
+
+ my $glue = Mac::Glue->new('My App', ppc => 'My App Name',
+ 'Server Name', 'Zone');
+
+You may also specify a process serial number:
+
+ my $glue = Mac::Glue->new('My App', psn => $psn);
+
+Note that C<$psn> should be a regular long integer, and will be packed into
+a double long behind the scenes. If this confuses you, don't worry about
+it; the values returned from the Mac::Processes module are good to pass
+back in as C<$psn>.
+
+You can also pass a path to an application:
+
+ my $glue = Mac::Glue->new('My App', path => $path_to_file);
+
+New for Mac OS 9, you can send events over TCP/IP:
+
+ my $glue = Mac::Glue->new('My App', eppc => 'My App Name',
+ 'some.machine.com');
+
+
+Once you have your glue set up, you start calling events, as they are
+documented in the POD file for the glue. The events can be called
+case-insensitively, with the exception of those that match the names of
+the special methods (see L<"Special parameters and methods">). In that
+case, since the special methods are in all caps, the event methods can
+be called case-insensitively except for all caps. e.g., for an event
+named C<reply>, it could be called with:
+
+ $glue->Reply;
+ $glue->reply;
+ $glue->RePLY;
+
+However, it could not be called with C<$glue-E<gt>REPLY>, since that
+is reserved.
+
+All applications respond to events differently. Something that works for
+one application might not work for another, so don't use any of these examples
+as a way you should script a specific application. They are just hyopthetical
+examples, for the most part.
+
+Events sometimes accept parameters, sometimes they don't. The primary
+parameter of most events is a special parameter called the I<direct
+object> parameter. In your event call, pass the data for that parameter
+first:
+
+ $glue->open($file);
+
+Other parameters must be named and must be provided as key-value pairs,
+with the key as the name of the parameter, and the value as the
+parameter's data:
+
+ $glue->open($file, using => $myapp);
+
+Note that the direct object parameter is the only parameter that doesn't
+need a name in front of it, and must come first in the list if it is
+supplied at all.
+
+Mac::Glue will attempt to coerce passed data into the expected type.
+For example, if C<open> expects an alias, the file specification in
+C<$file> will be turned into an alias before being added to the event.
+
+You can override this behavior with the C<param_type> function. If
+C<open> expects an alias (C<typeAlias>), but you want to pass text,
+you can do:
+
+ $glue->open( param_type(typeChar, $path) );
+
+Each datum can be a simple scalar as above, an AEDesc object,
+an Mac::AEObjDesc object (returned by C<obj>, C<prop>, and event methods),
+an Mac::AEEnum object (returned by the C<enum> function), or an array or hash
+reference, corresponding to AE lists and records. In this example, we
+nest them, with an arrayref as one of the values in the hashref, so the
+AE list is a datum for one of the keys in the AE record:
+
+ $glue->make(new => 'window', with_properties =>
+ {name => "New Window", position => [100, 200]});
+
+The words "name" and "position" will be changed into the proper
+corresponding AE IDs. And on return, record keys will be changed back
+from the AE IDs into the English words.
+
+Events return direct object parameters, turned into suitable data for
+use in the program. Aliases are resolved into file specifications, AE
+records and lists are turned into Perl hashes and arrays (recursively,
+for nested lists), etc.
+
+ my @urls = $sherlock->search_internet('AltaVista',
+ 'for' => 'Mac::Glue');
+
+AE objects (which will be discussed later) are returned as C<Mac::AEObjDesc>
+objects, so they may be used again by being passed back to another
+event.
+
+ my $window_object = $glue->get( window => 1 );
+ $glue->save($window_object);
+
+This allows AppleScript-like loops:
+
+ my @selection = $glue->get( $glue->prop(selection => of => window) );
+ my @owners;
+ for my $item (@selection) {
+ push @owners, $glue->get( $glue->obj(cell => 'Owners' => $item) );
+ }
+
+Some objects may allow an easy way to get a human-readable form, with the
+C<as> parameter:
+
+ my $item = $glue->get( file => 1, as => 'string' );
+
+Errors are returned in the special variable C<$^E>, which should be
+checked immediately after an event call.
+
+ $glue->close(window => 1);
+ if ($^E) {
+ warn "Couldn't close window: $^E\n";
+ }
+
+Or, if a value is expected and none is returned:
+
+ my $file = $glue->choose_file('Select a file, please.')
+ or die "No file chosen: $^E";
+
+Checking C<$^E> only works if the error returned is an error number.
+If it isn't, the actual error is available from the reply event,
+which can be accessed by using the C<RETOBJ> parameter (described
+below in L<"Special parameters and methods">).
+
+You can also handle errors with the C<ERRORS> handlers (also
+described below in L<"Special parameters and methods">).
+
+
+=head2 Creating object specifier records
+
+This is one of the more complex parts of Apple events, and it is only
+partially implemented (though full implementation is expected
+eventually, and most of it is implemented now).
+
+Object specifier records are created by the C<obj> method, and have
+four components to them.
+
+=over 4
+
+=item class
+
+=item container
+
+=item form
+
+=item data
+
+=back
+
+The class and data are passed as key-value pairs, like in AE records or
+parameter lists. The form and the type of the data are determined by
+the glue data or a good guess. The container is determined by the order
+of the key-value pairs: each pair is contained by the pair or object that
+follows it.
+
+ my $obj = $glue->obj(file => 'foo', folder => 'bar', disk => 'buz');
+
+So you have three pairs. The key of each pair ("file", "folder", "disk")
+is the class. The value of each pair ("foo", "bar", "baz") is the data.
+Because the data are each text, the form defaults to formName,
+and the data type defaults to typeChar (TEXT). If the data is
+a number, then the form would be formAbsolutePosition, and the data type
+would be typeLongInteger.
+
+So that leaves only the container. Each pair is contained by the pair
+following it. The disk contains the folder, the folder contains the file.
+The disk has no container (its container is null).
+
+Easy, right? I hope so. That's the idea. But let's go back to the
+forms, since that is the only tough part left.
+
+The primary forms are types, names, unique IDs, absolute positions,
+relative positions, tests, and ranges. Normally, text data has form
+name and type TEXT. Integer data has absolute position form, and
+integer type. The C<obj_form> function accepts three parameters, which
+allows you to set the form and data, or form, type, and data, in case
+you want to send data different from how Mac::Glue would guess.
+
+These two are the same, since in the second case, the other is assumed:
+
+ use Mac::Glue ':glue';
+
+ $obj1 = $glue->obj(window =>
+ obj_form(formAbsolutePostion, typeLongInteger, 1));
+
+ $obj2 = $glue->obj(window => 1);
+
+Special constants are exported that specify relative positions and
+absolute positions.
+
+ $first = $glue->obj(file => gFirst, property => 'Desktop');
+ $second = $glue->obj(file => gNext, $first);
+
+ for ($first, $second) {
+ print $glue->get($_, as => 'string');
+ }
+
+C<of> and C<in> are synonyms of C<property>:
+
+ $glue->obj(file => gFirst, property => 'Desktop');
+ $glue->obj(file => gFirst, of => 'Desktop');
+ $glue->obj(file => gFirst, in => 'Desktop');
+
+The "as" parameter above has a form of type, such as:
+
+ obj_form(formPropertyID, typeType, 'string');
+
+Then "string" is turned into a four-character ID behind the scenes (in
+this case, it is "TEXT").
+
+A special method called C<prop> is for specifying properties. These are
+equivalent:
+
+ $glue->obj(property => 'Desktop');
+ $glue->prop('Desktop');
+
+
+=head2 Descriptor types for object specifier records
+
+=over 4
+
+=item Property IDs
+
+Normally, the glue will know a property is expected and coerce whatever
+string you provide into its four-character ID. Sometimes
+C<obj_form(formPropertyID, typeType, 'property_name')> may be
+appropriate.
+
+=item Name
+
+Just pass the data as text. If there is some ambiguity, you may explicitly
+use C<obj_form(formName, typeChar, 'string')>.
+
+=item Unique IDs
+
+Could be anything.
+
+=item Absolute position
+
+As discussed above, if it is an index number, you can just pass the number,
+as in C<window =E<gt> 1>, or you can explicitly mark it with
+C<window =E<gt> obj_form(formAbsolutePosition, typeLongInteger, 1)>.
+
+For other absolutes, you may use constants, such as
+C<window =E<gt> gLast>. Choices are C<gFirst>, C<gMiddle>,
+C<gLast>, C<gAny>, C<gAll>.
+
+These are just shortcuts for explicit forms like
+C<obj_form(formAbsolutePosition, typeAbsoluteOrdinal, kAEAll)>.
+
+Note that if there is a plural form of the class name, you may use it
+to mean the same thing as "I<class> =E<gt> gAll". These are all the
+same:
+
+ $f->obj(files => of => 'System Folder');
+ $f->obj(files => gAll, of => 'System Folder');
+ $f->obj(file => gAll, of => 'System Folder');
+
+=item Relative position
+
+Similar to absolute position, but an additional object must be
+specified, such as C<file => gNext, file => gMiddle>, which would
+return the file after the middle file. Available constants are C<gNext>
+and C<gPrevious>.
+
+The explicit form is C<obj_form(formRelativePosition, typeEnumerated, kAENext)>.
+
+=item Ranges
+
+The C<range> function accepts two arguments, the start and stop ranges.
+
+ range(START, STOP)
+
+Each can be a number index, an absolute position constant, a string, or
+another data type passed with C<obj_form>. Here are a few ways to specify
+files in the System Folder:
+
+ $f->obj(files => range(1, 5), of => 'System Folder');
+ $f->obj(files => range(1, "System"), of => 'System Folder');
+ $f->obj(files => range("Finder", "System"), of => 'System Folder');
+ $f->obj(files => range(gFirst, "System"), of => 'System Folder');
+
+=item Whose tests
+
+The C<whose> function accepts either logical records or comparison
+records.
+
+ # comparison record
+ $f->obj(CLASS => whose(CLASS => VALUE, OPERATOR, VALUE));
+ $f->obj(CLASS => whose(PROPERTY, OPERATOR, VALUE));
+
+PROPERTY and CLASS => VALUE work like prop() and obj(). The PROPERTY
+form is the same as C<property =E<gt> VALUE>.
+
+OPERATOR is C<contains>, C<equals>, C<begins_with>, C<ends_with>,
+C<l_t>, C<l_e>, C<g_t>, or C<g_e>. VALUE is the value to compare to.
+
+ # files whose name begins with "foo"
+ $f->obj(files => whose(name => begins_with => 'foo'));
+
+ # rows whose first cell equals "bar"
+ $f->obj(rows => whose(cell => 1 => equals => 'bar'));
+
+
+Then there is the logical record type, for use when more than one comparison
+record is needed.
+
+ # logical record
+ $f->obj(CLASS => whose(OPERATOR, LIST));
+
+OPERATOR is C<AND>, C<OR>, or C<NOT>. LIST is any number of other logical
+records or comparison records, contained in anonymous arrays. So you can
+join any number of records together:
+
+ # words where it contains "e" and it begins with "p" and it does not end with "s"
+ $aw->obj(
+ words => whose(AND =>
+ [it => contains => 'e'], [it => begins_with => 'p'],
+ [NOT => [it => ends_with => 's']]
+ ), $text)
+
+Note how each logical record and comparison record following each logical
+operator is in an anonymous array. Also not how the special word "it"
+refers to the object being examined.
+
+=back
+
+There's one more record type that works similarly to the above object
+specifier records, but is not exactly the same thing.
+It's called an I<insertion location record>, and is created like this:
+
+ location(POSITION[, OBJECT])
+
+POSITION is a string, and can be one of C<before>, C<after>, C<beginning>,
+or C<end>. C<front> is a synonym for C<beginning>, and C<back> and C<behind>
+are synonyms for C<after>.
+
+OBJECT is the object to be positioned against, and will be the null object
+if not supplied.
+
+ my $aw = new Mac::Glue 'AppleWorks';
+ my $text = $aw->prop(text_body => document => 1);
+ $aw->activate;
+
+ # note null object in location()
+ $aw->make(new => 'document', at => location('front'));
+ $aw->set($text, to => "foo bar buz baz.");
+
+ $aw->move(
+ $aw->obj(word => 4 => $text),
+ to => location(after => $aw->obj(word => 2 => $text))
+ );
+
+
+=head2 Special parameters and methods
+
+Special parameters can be passed in the event which control certain
+aspects of the event call's behavior. They can be passed as parameters
+(affecting only the one event), or called as methods (which affect every
+call made from that object). They are all upper case.
+
+ $glue->REPLY(1); # wait for reply on all events
+ $glue->close(REPLY => 0); # don't wait for this one event
+
+=over 4
+
+=item REPLY
+
+Boolean, for whether or not to wait for a reply. Default is to wait.
+
+=item MODE
+
+Set other modes, such as C<kAENeverInteract>. This value is OR'd
+together with the REPLY value. Default is C<kAECanInteract |
+kAECanSwitchLayer>.
+
+=item SWITCH
+
+Switch to the application being called. Usually more efficient to use
+the C<activate> event:
+
+ $glue->activate;
+
+=item PRIORITY
+
+Set the event priority. Default is C<kAENormalPriority>.
+
+=item TIMEOUT
+
+Number of seconds to wait before timing out. Default is a couple
+hundred thousand seconds or so.
+
+=item RETOBJ
+
+Boolean, for whether or not the event call will return the direct object
+data (the default), or a Mac::AppleEvents::Simple object, containing
+references to the actual event and reply, so you can do more advanced
+things with the data if you want to.
+
+=item ERRORS
+
+A subroutine reference that will handle any errors (that is, will
+be executed only if C<$^E> is true) after the event is executed.
+Your handler will be passed 6 or more arguments:
+
+ 0 The glue object
+ 1 The event object (same object returned by RETOBJ)
+ 2 The Glue's name
+ 3 The event's name
+ 4 The error message
+ 5 The error number
+ 6..n Any arguments passed to the event in the first place
+
+Example:
+
+ sub error_handler {
+ my($glue, $event, $gluename, $eventname,
+ $errs, $errn, @args) = @_;
+ my $args = join ', ', @args;
+ die "$gluename->$eventname($args) event failed:\n$errs\n";
+ }
+
+ $finder->open(
+ $finder->obj( item => 'HD' ), # nothing named HD in Finder
+ ERRORS => \&error_handler
+ );
+
+Result:
+
+ # Finder->open(DOBJ, Mac::AEObjDesc=HASH(0xc4c0814)) event failed:
+ No such object (OS error -1728)
+
+=back
+
+=head2 Editing a Glue
+
+There is an included droplet, F<glueedit>, for editing glues. Drop
+a created glue on the droplet, and it will make a text file on the
+Desktop. Edit it, and then drop the text file back on the droplet.
+Be careful; this obviously can be dangerous. If you break something,
+you can use F<gluemac> to recreate the original glue, of course.
+
+Why would you edit a glue? Well, sometimes AETE resources are wrong. :)
+
+
+=head1 EXPORT
+
+Mac::Glue has two export sets. C<glue> exports the constants
+and functions beginning with "glue" listed in
+L<"Creating Object Specifier Records">, as well as the functions
+C<obj_form>, C<enum>, C<location>, C<range>, and C<whose>.
+C<all> exports everything from Mac::AppleEvents and
+Mac::AppleEvents::Simple, including all functions and constants.
+Nothing is exported by default.
+
+ use Mac::Glue ':glue'; # good for most things
+ use Mac::Glue ':all'; # for more advanced things
+
+
+=head1 TIPS
+
+=head2 Hide background apps
+
+ use Mac::Glue;
+ use Mac::Apps::Launch;
+ $a = new Mac::Glue 'Acrobat Exchange';
+ $a->launch;
+ Hide($a->{ID});
+
+ # now do your thing ...
+
+=head2 Scripting Addition Maintenance
+
+If you have a lot of scripting additions, it can slow down Mac::Glue
+(on startup) and take up more RAM. Same thing goes for Mac OS in general;
+each installed additions takes up more RAM and has to be loaded into
+the system, taking up extra time. So only keep installed the ones
+you want installed.
+
+If you have a huge scripting addition and you only want to use a small
+part of its functionality, you could also edit the glue and strip
+out portions you don't want. This is not recommended for those who
+don't know precisely what they are doing, and the gains may be
+unnoticable anyway.
+
+
+=head1 GOTCHAS
+
+=over 4
+
+=item *
+
+MAKE SURE F<site_perl> COMES FIRST IN YOUR LIBRARY PREFERENCES.
+Thank you. :-)
+
+=item *
+
+Do NOT send an event to the MacPerl application itself and expect a reply.
+Instead, try C<$macperlglue-E<gt>REPLY(0)>. Similarly, do not drop
+MacPerl onto F<gluemac>. Instead, you can make a copy of the MacPerl
+application, and drop that on F<gluemac>.
+
+=item *
+
+You should have the latest cpan-mac distribution is installed.
+
+=item *
+
+You should delete old dialect glue files manually if running Mac OS 9.
+
+=back
+
+
+=head1 TODO / BUGS
+
+=over 4
+
+=item *
+
+Specifying other attributes (transactions, etc.)
+
+=item *
+
+Add more coercions etc. to Mac::AppleEvents::Simple (feedback
+wanted on this, let me know what I missed)
+
+=item *
+
+Add comparison operators from glues ?
+
+=item *
+
+"tell" objects to do events
+
+=item *
+
+New AETE flags in Mac OS 8.5, Mac OS 9? Anything else new? Anything
+missing in backward compatibility to 7.5?
+
+=item *
+
+System of versioning (for glues and target apps) for distribution
+of modified glues
+
+=item *
+
+MacPerl (I think) needs a new idle function for waiting for
+replies
+
+=item *
+
+MacPerl hangs if it waits for a reply after sending an event to
+itself
+
+=item *
+
+Handlers (on foo ...) ?
+
+=item *
+
+Callbacks (some support exists, Cameron Ashby E<lt>[email protected]<gt>,
+see Mac::AppleEvents::Simple) ?
+
+=item *
+
+Add dynamic fetching of glues?
+
+=back
+
+
+=head1 HISTORY
+
+=over 4
+
+=item v1.00, Tuesday, September 12, 2000
+
+Added error handling via ERRORS parameter / method.
+
+General cleanup, additional examples.
+
+=item v0.58, Tuesday, November 16, 1999
+
+Change all of the classes to have C<Mac::> at the beginning of them
+(except for ones that originate elsewhere, like C<AEDesc>, et al).
+
+Added C<Mac::AEParamType> and C<param_type>.
+
+If a parameter expects an AE object specifier record, and is not passed one,
+then it guesses the type and sets it to either C<typeChar> or C<typeInteger>.
+
+Made the conversion of keys into English names recursive with lists,
+in addition to records (i.e., lists can contain multiple records).
+
+
+=item v0.57, Tuesday, November 2, 1999
+
+Added conversion of keys in returned records back into the "English" names.
+
+Records containing C<class> parameter are coerced into descriptors of
+that class (i.e., C<{name =E<gt> 'foo', class =E<gt> 'disk'}>).
+
+Added support for events over TCP/IP (Mac OS 9 required).
+
+Note: if Keychain Access is used in Mac OS 9, the C<login> method may no
+longer be required for accessing of remote machines.
+
+Fixed bug in C<can> method; also changed how C<can> calls C<AUTOLOAD>.
+
+Added code for experimental callback stuff, undocumented,
+subject to change, and probably does not even work.
+
+Changed C<_get_name> to C<_get_id>, created new C<_get_name>.
+
+Updated dialect creation code for Mac OS 9 (aeut is now stored in
+the F<AppleScript> extension instead of a dialect file, but for
+Mac::Glue is still stored in the F<dialects> folder. Instead
+of being called F<English>, it will likely be called F<AppleScript>.
+You should delete (or archive) old dialect glues manually.
+
+
+=item v0.56, Friday, September 10, 1999
+
+If plural class is used (i.e., I<files> for I<file>), and the following value
+is not an C<AE*> object, then it will become "every I<class>".
+(Jeff Lowrey)
+
+Added more documentation about using C<AEObjDesc> objects. (Jeff Lowrey)
+
+=item v0.55, Thursday, September 2, 1999
+
+Added extra arguments to C<new> to accept
+alternate targets. PPC ports, PSNs, and paths are explicitly accepted now.
+(Paths are first launched, then the PSN is found ... aliases won't
+work properly as paths.)
+
+Added C<login> class method to tell MacPerl to try logging in
+with specified username and password. Requires F<Login As>
+OSAX from the F<GTQ Scripting Library>.
+
+=item v0.51, Wednesday, September 1, 1999
+
+Changed ordering of search in C<_find_event>.
+
+Fixed doc problems in Mac::AETE::Format::Glue: inheritance
+classes are named, and optional parameters are properly
+denoted.
+
+=item v0.50, 12 July 1999
+
+Added g* constants in addition to glue* constants. Use whichever
+you like, but I will use g* for everything. If you don't want the
+g* constants, because they conflict with something, use the
+C<:long> and C<:longall> import tags instead of C<:glue> and C<:all>.
+
+Gone to beta! Woo!
+
+=item v0.31, 22 June 1999
+
+Fixed bug that only found class names instead of class and property
+names in creation of object specifier records.
+
+Fixed bug which changed directories on initialization, and didn't change
+it back.
+
+Allow case-insensitive parameter names.
+
+=item v0.30, 16 June 1999
+
+Changed function names:
+C<glueInsertion> is now C<location>, C<glueRange> is now C<range>.
+
+Added C<whose> function.
+
+Added C<can> method which correctly finds available events.
+
+Made special parameters, formerly with leading underscore and lowercase,
+to all uppercase with no underscore (i.e., C<_retobj> is now C<RETOBJ>).
+
+Added C<of> and C<in> as synonyms for C<property> in C<obj> method calls.
+
+Put C<AEObjDesc> back in! Will use in the future, maybe, to use objects
+as targets for events.
+
+Return all descriptors from C<obj> and C<prop>, and all objects
+returned from events, as C<AEObjDesc> objects.
+
+Added C<glueTrue> and C<glueFalse> constants.
+
+Tried again to suppress warnings during initial scripting additions and
+dialect creation.
+
+Tons of internal cleaning up.
+
+=item v0.26, 07 June 1999
+
+Made choice of serializer for glue more intelligent: FreezeThaw
+automatically picked for CFM68K, Storable for PPC.
+
+Updated Mac::AppleEvents and Mac::Memory, fixed more bugs and
+added constants. Fixed bug in AutoSplit.
+
+Added C<glueInsertion>, C<glueRange>, and C<glueNull>.
+
+Completely removed C<AEObjDesc> package, which existed to support
+destruction of descriptors. Use global hash now to keep track
+of descriptors to destroy (L<Mac::AppleEvents::Simple>). So
+all descriptors returned from C<obj> and C<prop> and others are
+C<AEDesc> objects.
+
+Changed ordering of items in creating object specifiers in
+C<_do_obj> to match AppleScript, so comparing to Capture AE
+output would be easier.
+
+Put C<%AE_PUT> back in Mac::Glue and left C<%AE_GET> in
+Mac::AppleEvents::Simple.
+
+Switched C<DOBJ, {PARAM1 =E<gt> DATA1}> to C<DOBJ, PARAM1 =E<gt> DATA1>
+in event calls.
+
+Always default to wait for reply and no timeout if unspecified by user.
+
+Return useful errors in C<$^E>.
+
+Accept and return nested arrays/lists and hashes/records.
+
+Call events and pass classes / properties case-insensitively.
+
+
+Other miscellaneous changes. Some cleaning up.
+
+=item v0.25, 30 May 1999
+
+Add serializer option.
+
+Updates to Mac::Memory and Mac::AppleEvents and Mac::AppleEvents::Simple.
+
+Added constants for absolute and relative positions.
+
+Added C<enum>.
+
+Put C<o> and C<p> back as C<obj> and C<prop>.
+
+Other miscellaneous changes. Lots of cleaning up.
+
+=item v0.20, 22 May 1999
+
+Complete rewrite. Too many changes to bother mentioning, because I am lazy.
+
+=item v0.09, 13 October 1998
+
+Added ability to use properties. These are called with the C<p> method:
+
+ $obj->get($obj->p('label_index', item=>'HD'));
+
+which is equivalent to:
+
+ $obj->get($obj->o(property=>'label_index', item=>'HD'));
+
+=item v0.08, 10 October 1998
+
+Unreleased.
+
+Significant cleanup of module, in large part unfinished changes from
+last version.
+
+No longer doing error checking for whether lists are allowed or objects
+are allowed, because these are sometimes wrong or undetectable. Also,
+will not raise exception on a missing required parameter, but will warn
+if C<-w> is on.
+
+C<obj_form> is exported from the glue modules, and all of the functions
+and constant from C<Mac::AppleEvents> can be imported from a glue module
+with the C<:all> tag:
+
+ use Mac::Glue::SomeApp qw(:all);
+
+=item v0.07, 30 September 1998
+
+More documentation and bugfixes. Having serious problems with
+C<AEObjDesc::DESTROY>.
+
+=item v0.06, 29 September 1998
+
+Whole bunches of changes. Note that glues made under 0.05 no longer work.
+
+=back
+
+
+=head1 AUTHOR
+
+Chris Nandor E<lt>[email protected]<gt>, http://pudge.net/
+
+Copyright (c) 1998-2000 Chris Nandor. All rights reserved. This program
+is free software; you can redistribute it and/or modify it under the terms
+of the Artistic License, distributed with Perl.
+
+
+=head1 THANKS
+
+Matthias Neeracher E<lt>[email protected]<gt>,
+David Schooley E<lt>[email protected]<gt>,
+Graham Barr E<lt>[email protected]<gt>,
+John W Baxter E<lt>[email protected]<gt>,
+Marion Delgado E<lt>[email protected]<gt>,
+Eric Dobbs E<lt>[email protected]<gt>,
+Josh Gemmell E<lt>[email protected]<gt>,
+Alex Harper E<lt>[email protected]<gt>,
+Nathaniel Irons E<lt>[email protected]<gt>,
+Dave Johnson E<lt>[email protected]<gt>,
+Bart Lateur E<lt>[email protected]<gt>,
+Jefferson R. Lowrey E<lt>[email protected]<gt>,
+Mat Marcus E<lt>[email protected]<gt>,
+Larry Moore E<lt>[email protected]<gt>,
+Ricardo Muggli E<lt>[email protected]<gt>,
+Vincent Nonnenmacher E<lt>[email protected]<gt>,
+Henry Penninkilampi E<lt>[email protected]<gt>,
+Peter Prymmer E<lt>[email protected]<gt>,
+Ramesh R. E<lt>[email protected]<gt>,
+Axel Rose E<lt>[email protected]<gt>,
+Stephan Somogyi E<lt>[email protected]<gt>,
+Kevin Walker E<lt>[email protected]<gt>,
+Matthew Wickline E<lt>[email protected]<gt>.
+
+(If I left your name out, please remind me.)
+
+
+=head1 SEE ALSO
+
+Mac::AppleEvents, Mac::AppleEvents::Simple, macperlcat, Inside Macintosh:
+Interapplication Communication.
+
+ http://sourceforge.net/projects/mac-glue/
+
+=cut
+
+
+=head1 VERSION
+
+v1.00, Tuesday, September 12, 2000
==== //depot/maint-5.6/macperl/macos/lib/Mac/OSA/Simple.pm#1 (text) ====
Index: perl/macos/lib/Mac/OSA/Simple.pm
--- perl/macos/lib/Mac/OSA/Simple.pm.~1~ Wed Oct 3 13:15:05 2001
+++ perl/macos/lib/Mac/OSA/Simple.pm Wed Oct 3 13:15:05 2001
@@ -0,0 +1,468 @@
+package Mac::OSA::Simple;
+
+use strict;
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS
+ %ScriptComponents);
+use Mac::Components;
+use Mac::OSA;
+use Mac::AppleEvents;
+use Mac::Resources;
+use Mac::Memory;
+use Exporter;
+use Carp;
+
+@ISA = qw(Exporter);
+@EXPORT = qw(frontier applescript osa_script
+ compile_applescript compile_frontier compile_osa_script
+ load_osa_script %ScriptComponents);
+@EXPORT_OK = @Mac::OSA::EXPORT;
+%EXPORT_TAGS = (all => [@EXPORT, @EXPORT_OK]);
+$VERSION = '0.51';
+
+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, $value, $return) = ($_[0], '', '');
+
+ $value = OSAExecute($self->{COMP}, $self->{ID}, 0, 0)
+ or _mydie() && return;
+
+ if ($value) {
+ $return = OSADisplay($self->{COMP}, $value, 'TEXT', 0)
+ or _mydie() && return;
+ OSADispose($self->{COMP}, $value);
+ }
+
+ $self->{RETURN} = $return && $return->isa('AEDesc')
+ ? $return->get : 1;
+
+ AEDisposeDesc($return) if $return;
+
+ $self->{RETURN};
+}
+
+sub dispose {
+ my $self = shift;
+
+ if ($self->{ID} && $self->{COMP}) {
+ OSADispose($self->{COMP}, $self->{ID});
+ delete $self->{ID};
+ }
+
+ if ($self->{SCRIPT}) {
+ AEDisposeDesc($self->{SCRIPT});
+ delete $self->{SCRIPT};
+ }
+
+ 1;
+}
+
+sub save {
+ my($self, $file, $resid, $name, $len, $scpt, $res, $foo) = @_;
+
+ $scpt = $self->compiled or _mydie() && return;
+
+ $resid = defined($resid) ? $resid : 128;
+ $name = defined($name) ? $name : 'MacPerl Script';
+
+ unless (-e $file) {
+ CreateResFile($file) or _mydie() && return;
+ MacPerl::SetFileInfo('ToyS', 'osas', $file);
+ }
+
+ $res = FSpOpenResFile($file, 0) or _mydie() && return;
+ $foo = Get1Resource(kOSAScriptResourceType, $resid);
+ if (defined $foo) {
+ RemoveResource($foo) or _mydie() && return;
+ }
+
+ AddResource($scpt, kOSAScriptResourceType, 128, $name)
+ or _mydie() && return;
+
+ UpdateResFile($res) or _mydie() && return;
+ CloseResFile($res);
+
+ 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};
+}
+
+
+sub compiled {
+ my($self, $script) = @_;
+
+ $script = OSAStore(@$self{qw(COMP ID)}, typeOSAGenericStorage, 0)
+ or _mydie() && return;
+
+ push @{$self->{AEDESC}}, $script;
+
+ $script->data;
+}
+
+sub _doscript {
+ my($c, $text, $self, $return) = @_;
+ $self = _compile_script($c, $text) or _mydie() && return;
+ $return = $self->execute or _mydie() && return;
+ $self->dispose;
+ $return;
+}
+
+sub _load_script {
+ my($scpt, $from_file, $resid, $c, $desc, $self, $res) = @_;
+
+ $c = kOSAGenericScriptingComponentSubtype;
+ $self = bless {COMP => $ScriptComponents{$c},
+ TYPE => $c}, __PACKAGE__;
+
+ if ($from_file) {
+ my($resc, $file);
+ $resid = defined($resid) ? $resid : 128;
+ $file = $scpt;
+ $res = FSpOpenResFile($file, 0) or _mydie() && return;
+ $scpt = Get1Resource(kOSAScriptResourceType, $resid)
+ or _mydie() && return;
+ }
+
+ unless ($scpt->isa('Handle')) {
+ die "data is not of type Handle"; # did you mean to
+ # specify a file instead?
+ }
+
+ $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;
+
+ $self;
+}
+
+sub _compile_script {
+ my($c, $text, $comp, $script, $self) = @_;
+ $self = bless {COMP => $ScriptComponents{$c},
+ SOURCE => $text, TYPE => $c}, __PACKAGE__;
+ $self->_compile;
+}
+
+sub _compile {
+ my $self = shift;
+ my($text, $comp, $script, $id);
+ $self->{SCRIPT} = AECreateDesc('TEXT', $self->{SOURCE}) or
+ _mydie() && return;
+ $self->{ID} = OSACompile($self->{COMP}, $self->{SCRIPT}, 0) or
+ _mydie() && return;
+ $self;
+}
+
+sub _mydie {
+ # maybe do something here some day
+ 1;
+}
+
+sub DESTROY {
+ my $self = shift;
+ if (exists($self->{ID}) || exists($self->{SCRIPT})) {
+ $self->dispose;
+ }
+ if ($self->{AEDESC}) {
+ for (@{$self->{AEDESC}}) {
+ AEDisposeDesc($_);
+ }
+ }
+}
+
+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);
+}
+
+sub FETCH {
+ my($self, $comp, $c) = @_;
+
+ $c = $comp;
+ if ($comp eq kOSAGenericScriptingComponentSubtype) {
+ $c = 0;
+ $c++ while exists $self->{$c}; # get unique key
+ }
+
+ if (!$self->{$c}) {
+ $self->{$c} =
+ OpenDefaultComponent(kOSAComponentType(), $comp) or
+ Mac::OSA::Simple::_mydie() && return;
+ }
+ $self->{$c};
+}
+
+package Mac::OSA::Simple; # odd "fix" for AutoSplit
+
+1;
+__END__
+
+=head1 NAME
+
+Mac::OSA::Simple - Simple access to Mac::OSA
+
+=head1 SYNOPSIS
+
+ #!perl -wl
+ use Mac::OSA::Simple;
+ osa_script('LAND', <<'EOS');
+ dialog.getInt ("Duration?",@examples.duration);
+ dialog.getInt ("Amplitude?",@examples.amplitude);
+ dialog.getInt ("Frequency?",@examples.frequency);
+ speaker.sound (examples.duration, examples.amplitude,
+ examples.frequency)
+ EOS
+
+ print frontier('clock.now()');
+
+ applescript('beep 3');
+
+=head1 DESCRIPTION
+
+ **MAJOR CHANGE**
+ Scripting component in osa_script and compile_osa_script
+ is now the first parameter, not the second.
+ Now the script text is second.
+
+You can access scripting components via the tied hash
+C<%ScriptComponents> which is automatically exported. Components are
+only opened if they have not been already, and are closed when the
+program exits. It is normally not necessary to use this hash, as it is
+accessed internally when needed.
+
+Also usually not necessary, but possibly useful, are all the functions
+and constants from Mac::OSA, available with the EXPORT_TAG "all".
+
+
+=head2 Functions
+
+The following functions are automatically exported.
+
+=over 4
+
+=item osa_script(SCRIPTCOMPONENT, SCRIPTTEXT)
+
+Compiles and executes SCRIPTTEXT, using four-char SCRIPTCOMPONENT.
+Component is opened and closed behind the scenes, and SCRIPTTEXT
+is compiled, executed, and disposed of behind the scenes. If
+the script returns data, the function returns the data, else it
+returns 1 or undef on failure.
+
+=item applescript(SCRIPTTEXT)
+
+=item frontier(SCRIPTTEXT)
+
+Same thing as C<osa_script> with SCRIPTCOMPONENT already set
+('ascr' for AppleScript, 'LAND' for Frontier).
+
+
+=item compile_osa_script(SCRIPTCOMPONENT, SCRIPTTEXT)
+
+Compiles script as C<osa_script> above, but does not execute it.
+Returns Mac::OSA::Simple object. See L<"Methods"> for more information.
+
+=item compile_applescript(SCRIPTTEXT)
+
+=item compile_frontier(SCRIPTTEXT)
+
+Same thing as C<compile_osa_script> with SCRIPTCOMPONENT already set.
+
+
+=item load_osa_script(HANDLE)
+
+=item load_osa_script(FILE, FROMFILE [, RESOURCEID])
+
+In the first form, load compiled OSA script using data in HANDLE
+(same data as returned by C<compiled> method; see L<Mac::Memory>).
+In the second form, with FROMFILE true, gets
+script from FILE using RESOURCEID (which is 128 by default). Returns
+Mac::OSA::Simple object.
+
+ **NOTE**
+ This function uses FSpOpenResFile, which has a bug in it
+ that causes it to treat $ENV{MACPERL} as the current
+ directory. For safety, always pass FILE as an absolute
+ path, for now.
+
+Example:
+
+ use Mac::OSA::Simple qw(:all);
+ use Mac::Resources;
+ $res = FSpOpenResFile($file, 0) or die $^E;
+ $scpt = Get1Resource(kOSAScriptResourceType, 128)
+ or die $^E;
+ $osa = load_osa_script($scpt);
+ $osa->execute;
+ CloseResFile($res);
+
+Same thing:
+
+ use Mac::OSA::Simple;
+ $osa = load_osa_script($file, 1);
+ $osa->execute;
+
+Another example:
+
+ use Mac::OSA::Simple;
+ $osa1 = compile_applescript('return "foo"');
+ print $osa1->execute;
+
+ # make copy of script in $osa1 and execute it
+ $osa2 = load_osa_script($osa1->compiled);
+ print $osa2->execute;
+
+See L<"Methods"> for more information.
+
+=back
+
+
+=head2 Methods
+
+This section describes methods for use on objects returned by
+C<compile_osa_script> and its related functions and C<load_osa_script>.
+
+=over 4
+
+=item compiled
+
+Returns a HANDLE containing the raw compiled form of the script
+(see L<Mac::Memory>).
+
+=item dispose
+
+Disposes of OSA script. Done automatically if not called explicitly.
+
+=item execute
+
+Executes script. Can be executed more than once.
+
+=item save(FILE [, ID [, NAME]])
+
+Saves script in FILE with ID and NAME. ID defaults to 128, NAME
+defaults to "MacPerl Script". DANGEROUS! Will overwrite
+existing resource!
+
+ **NOTE**
+ This function uses FSpOpenResFile, which has a bug in it
+ that causes it to treat $ENV{MACPERL} as the current
+ directory. For safety, always pass FILE as an absolute
+ path, for now.
+
+
+=back
+
+
+=head1 BUGS
+
+C<load_osa_script> function and C<save> method require absolute
+paths. Problem in Mac::Resources itself.
+
+=head1 TODO
+
+Work on error handling. We don't want to die when a toolbox function
+fails. We'd rather return undef and have the user check $^E.
+
+Should C<frontier> and/or C<osa_script('LAND', $script)> launch
+Frontier if it is not running?
+
+Add C<run_osa_script>, which could take script data in a Handle or
+a path to a script (as with C<load_osa_script>.
+
+Should C<save> have optional parameter for overwriting resource?
+
+Should C<run_osa_script> and C<execute> take arguments? If so, how?
+
+
+=head1 HISTORY
+
+=over 4
+
+Changed TEXT to SOURCE in internal hash storing text source of script.
+
+Added C<source> method (finish adding docs).
+
+Made calls for generic scripting component to C<%ScriptComponents>
+make new call to OpenComponent each time.
+
+=item v0.51, Saturday, March 20, 1999
+
+Fixed silly bug in return from execute, where multiline
+return values would not return (added /s so . would match \n)
+(John Moreno E<lt>[email protected]<gt>).
+
+=item v0.50, Friday, March 12, 1999
+
+Changed around the argument order for C<osa_script> and
+C<compile_osa_script>.
+
+Added C<load_osa_script> function.
+
+Added C<save> method.
+
+Added lots of tests.
+
+=item v0.10, Tuesday, March 9, 1999
+
+Added lots of stuff to get compiled script data.
+
+=item v0.02, May 19, 1998
+
+Here goes ...
+
+=back
+
+=head1 AUTHOR
+
+Chris Nandor E<lt>[email protected]<gt>, http://pudge.net/
+
+Copyright (c) 1999 Chris Nandor. All rights reserved. This program is
+free software; you can redistribute it and/or modify it under the terms
+of the Artistic License, distributed with Perl.
+
+=head1 SEE ALSO
+
+Mac::OSA, Mac::AppleEvents, Mac::AppleEvents::Simple, macperlcat.
+
+=head1 VERSION
+
+Version 0.51 (Saturday, March 20, 1999)
+
+=cut
==== //depot/maint-5.6/macperl/macos/lib/Mac/Toolbox.pod#1 (text) ====
Index: perl/macos/lib/Mac/Toolbox.pod
--- perl/macos/lib/Mac/Toolbox.pod.~1~ Wed Oct 3 13:15:05 2001
+++ perl/macos/lib/Mac/Toolbox.pod Wed Oct 3 13:15:05 2001
@@ -0,0 +1,154 @@
+=head1 NAME
+
+Mac::Toolbox - Introduction to the Macintosh Toolbox Modules
+
+=head1 SYNOPSIS
+
+=over 4
+
+=item Mac::AppleEvents
+
+Apple Event Manager.
+
+=item Mac::Components
+
+Component Manager.
+
+=item Mac::Controls
+
+Control Manager.
+
+=item Mac::Dialogs
+
+Dialog Manager.
+
+=item Mac::Events
+
+Event Manager.
+
+=item Mac::Files
+
+File Manager.
+
+=item Mac::Fonts
+
+Font Manager.
+
+=item Mac::Gestalt
+
+Gestalt Manager.
+
+=item Mac::InternetConfig
+
+InternetConfig System.
+
+=item Mac::Lists
+
+List Manager.
+
+=item Mac::Memory
+
+Memory Manager.
+
+=item Mac::Menus
+
+Menu Manager.
+
+=item Mac::MoreFiles
+
+More File Manager related routines.
+
+=item Mac::Movies
+
+Movie Manager.
+
+=item Mac::OSA
+
+Open Scripting Architecture.
+
+=item Mac::Processes
+
+Processe Manager.
+
+=item Mac::QDOffscreen
+
+Offscreen QuickDraw.
+
+=item Mac::QuickDraw
+
+QuickDraw.
+
+=item Mac::Resources
+
+Resource Manager.
+
+=item Mac::Speech
+
+Speech Manager.
+
+=item Mac::SpeechRecognition
+
+Speech Recognition Manager.
+
+=item Mac::StandardFile
+
+Standard File Dialogs.
+
+=item Mac::Types
+
+Toolbox Types.
+
+=item Mac::Windows
+
+Window Manager.
+
+=back
+
+=head1 DESCRIPTION
+
+The Macintosh Operating System provides a rich API with thousands of I<toolbox>
+calls. The MacPerl toolbox modules aim to make as much as possible of this
+functionality available to MacPerl programmers. The mapping of the toolbox
+interfaces into MacPerl is intended to be
+
+=over 4
+
+=item 1.
+
+Convenient to use for Perl programmers.
+
+=item 2.
+
+As close as possible to the C interfaces.
+
+=back
+
+This translates into a mapping strategy which is discussed in the following
+sections.
+
+=head2 Function mappings
+
+MacPerl toolbox calls take their input arguments in the same order as the
+corresponding toolbox functions. Output arguments are never passed by reference,
+but returned from the calls. If there are several output arguments, a list is
+returned. If an error occurs, the function returns C<undef> or C<()> and the
+error code is available in the C<$^E> variable.
+
+ $port = GetPort;
+ SetPort $port;
+ $desc = AECreateDesc("TEXT", "Hello, World") or die $^E;
+
+=head2 Data structure mappings
+
+Complex data structures are mapped into blessed references. Data fields are
+available through member functions which return the value of a field if called
+without an argument and change the value if called with an argument.
+
+ $rect = new Rect(10, 20, 110, 220);
+ $rect->top;
+ $rect->right(250);
+
+=head1 AUTHOR(S)
+
+Matthias Ulrich Neeracher <[email protected]>
+
End of Patch.