move tlperl.straw to tlperl

git-svn-id: svn://tug.org/texlive/trunk@18210 c570f23f-e606-0410-a88d-b1316a301751

1 files changed, 174 insertions, 0 deletions

diff --git a/Master/tlpkg/tlperl/lib/Win32/API/Callback.pm b/Master/tlpkg/tlperl/lib/Win32/API/Callback.pm
new file mode 100755
index 00000000000..df15786591b
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Win32/API/Callback.pm
@@ -0,0 +1,174 @@
+# See the bottom of this file for the POD documentation.  Search for the
+# string '=head'.
+
+#######################################################################
+#
+# Win32::API::Callback - Perl Win32 API Import Facility
+# 
+# Author: Aldo Calpini <dada@perl.it>
+# Maintainer: Cosimo Streppone <cosimo@cpan.org>
+#
+# $Id: Callback.pm 458 2009-01-17 17:27:43Z cosimo.streppone $
+#
+#######################################################################
+
+package Win32::API::Callback;
+
+$VERSION = '0.59';
+
+require Exporter;       # to export the constants to the main:: space
+require DynaLoader;     # to dynuhlode the module.
+@ISA = qw( Exporter DynaLoader );
+
+sub DEBUG { 
+	if ($WIN32::API::DEBUG) { 
+		printf @_ if @_ or return 1; 
+	} else {
+		return 0;
+	}
+}
+
+use Win32::API;
+use Win32::API::Type;
+use Win32::API::Struct;
+
+#######################################################################
+# This AUTOLOAD is used to 'autoload' constants from the constant()
+# XS function.  If a constant is not found then control is passed
+# to the AUTOLOAD in AutoLoader.
+#
+
+sub AUTOLOAD {
+    my($constname);
+    ($constname = $AUTOLOAD) =~ s/.*:://;
+    #reset $! to zero to reset any current errors.
+    $!=0;
+    my $val = constant($constname, @_ ? $_[0] : 0);
+    if ($! != 0) {
+        if ($! =~ /Invalid/) {
+            $AutoLoader::AUTOLOAD = $AUTOLOAD;
+            goto &AutoLoader::AUTOLOAD;
+        } else {
+            ($pack,$file,$line) = caller;
+            die "Your vendor has not defined Win32::API::Callback macro $constname, used at $file line $line.";
+        }
+    }
+    eval "sub $AUTOLOAD { $val }";
+    goto &$AUTOLOAD;
+}
+
+
+#######################################################################
+# dynamically load in the API extension module.
+#
+bootstrap Win32::API::Callback;
+
+#######################################################################
+# PUBLIC METHODS
+#
+sub new {
+    my($class, $proc, $in, $out) = @_;
+    my %self = ();
+
+	# printf "(PM)Callback::new: got proc='%s', in='%s', out='%s'\n", $proc, $in, $out;
+		
+	$self{in} = [];
+	if(ref($in) eq 'ARRAY') {
+		foreach (@$in) {
+			push(@{ $self{in} }, Win32::API::type_to_num($_));
+		}	
+	} else {
+		my @in = split '', $in;
+		foreach (@in) {
+			push(@{ $self{in} }, Win32::API::type_to_num($_));
+		}			
+	}
+	$self{out} = Win32::API::type_to_num($out);
+	$self{sub} = $proc;
+	my $self = bless \%self, $class;
+	
+	DEBUG "(PM)Callback::new: calling CallbackCreate($self)...\n";
+    my $hproc = CallbackCreate($self);
+
+	DEBUG "(PM)Callback::new: hproc=$hproc\n";
+
+    #### ...if that fails, set $! accordingly
+    if(!$hproc) {
+        $! = Win32::GetLastError();
+        return undef;
+    }
+    
+    #### ok, let's stuff the object
+    $self->{code} = $hproc;
+    $self->{sub}  = $proc;
+
+    #### cast the spell
+    return $self;
+}
+
+sub MakeStruct {
+	my($self, $n, $addr) = @_;	
+	DEBUG "(PM)Win32::API::Callback::MakeStruct: got self='$self'\n";
+	my $struct = Win32::API::Struct->new($self->{intypes}->[$n]);	
+	$struct->FromMemory($addr);
+	return $struct;
+}
+
+1;
+
+__END__
+
+#######################################################################
+# DOCUMENTATION
+#
+
+=head1 NAME
+
+Win32::API::Callback - Callback support for Win32::API
+
+=head1 SYNOPSIS
+
+  use Win32::API;
+  use Win32::API::Callback;
+
+  my $callback = Win32::API::Callback->new(
+    sub { my($a, $b) = @_; return $a+$b; },
+    "NN", "N",
+  );
+
+  Win32::API->Import(
+      'mydll', 'two_integers_cb', 'KNN', 'N',
+  );
+
+  $sum = two_integers_cb( $callback, 3, 2 );
+
+
+=head1 FOREWORDS
+
+=over 4
+
+=item *
+Support for this module is B<highly experimental> at this point.
+
+=item *
+I won't be surprised if it doesn't work for you.
+
+=item *
+Feedback is very appreciated.
+
+=item *
+Documentation is in the work. Either see the SYNOPSIS above
+or the samples in the F<samples> directory.
+
+=back
+
+=head1 AUTHOR
+
+Aldo Calpini ( I<dada@perl.it> ).
+
+=head1 MAINTAINER
+
+Cosimo Streppone ( I<cosimo@cpan.org> ).
+
+=cut
+