home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / Callback.pm < prev    next >
Encoding:
Perl POD Document  |  2003-03-10  |  3.9 KB  |  171 lines
  1. package Win32::API::Callback;
  2.  
  3. # See the bottom of this file for the POD documentation.  Search for the
  4. # string '=head'.
  5.  
  6. #######################################################################
  7. #
  8. # Win32::API::Callback - Perl Win32 API Import Facility
  9. # 
  10. # Version: 0.41
  11. # Date: 10 Mar 2003
  12. # Author: Aldo Calpini <dada@perl.it>
  13. # $Id: Callback.pm,v 1.0 2001/10/30 13:57:31 dada Exp $
  14. #######################################################################
  15.  
  16. $VERSION = "0.41";
  17.  
  18. require Exporter;       # to export the constants to the main:: space
  19. require DynaLoader;     # to dynuhlode the module.
  20. @ISA = qw( Exporter DynaLoader );
  21.  
  22. sub DEBUG { 
  23.     if ($WIN32::API::DEBUG) { 
  24.         printf @_ if @_ or return 1; 
  25.     } else {
  26.         return 0;
  27.     }
  28. }
  29.  
  30. use Win32::API;
  31. use Win32::API::Type;
  32. use Win32::API::Struct;
  33.  
  34. #######################################################################
  35. # This AUTOLOAD is used to 'autoload' constants from the constant()
  36. # XS function.  If a constant is not found then control is passed
  37. # to the AUTOLOAD in AutoLoader.
  38. #
  39.  
  40. sub AUTOLOAD {
  41.     my($constname);
  42.     ($constname = $AUTOLOAD) =~ s/.*:://;
  43.     #reset $! to zero to reset any current errors.
  44.     $!=0;
  45.     my $val = constant($constname, @_ ? $_[0] : 0);
  46.     if ($! != 0) {
  47.         if ($! =~ /Invalid/) {
  48.             $AutoLoader::AUTOLOAD = $AUTOLOAD;
  49.             goto &AutoLoader::AUTOLOAD;
  50.         } else {
  51.             ($pack,$file,$line) = caller;
  52.             die "Your vendor has not defined Win32::API::Callback macro $constname, used at $file line $line.";
  53.         }
  54.     }
  55.     eval "sub $AUTOLOAD { $val }";
  56.     goto &$AUTOLOAD;
  57. }
  58.  
  59.  
  60. #######################################################################
  61. # dynamically load in the API extension module.
  62. #
  63. bootstrap Win32::API::Callback;
  64.  
  65. #######################################################################
  66. # PUBLIC METHODS
  67. #
  68. sub new {
  69.     my($class, $proc, $in, $out) = @_;
  70.     my %self = ();
  71.  
  72.     # printf "(PM)Callback::new: got proc='%s', in='%s', out='%s'\n", $proc, $in, $out;
  73.         
  74.     $self{in} = [];
  75.     if(ref($in) eq 'ARRAY') {
  76.         foreach (@$in) {
  77.             push(@{ $self{in} }, Win32::API::type_to_num($_));
  78.         }    
  79.     } else {
  80.         my @in = split '', $in;
  81.         foreach (@in) {
  82.             push(@{ $self{in} }, Win32::API::type_to_num($_));
  83.         }            
  84.     }
  85.     $self{out} = Win32::API::type_to_num($out);
  86.     $self{sub} = $proc;
  87.     my $self = bless \%self, $class;
  88.     
  89.     DEBUG "(PM)Callback::new: calling CallbackCreate($self)...\n";
  90.     my $hproc = CallbackCreate($self);
  91.  
  92.     DEBUG "(PM)Callback::new: hproc=$hproc\n";
  93.  
  94.     #### ...if that fails, set $! accordingly
  95.     if(!$hproc) {
  96.         $! = Win32::GetLastError();
  97.         return undef;
  98.     }
  99.     
  100.     #### ok, let's stuff the object
  101.     $self->{code} = $hproc;
  102.     $self->{sub}  = $proc;
  103.  
  104.     #### cast the spell
  105.     return $self;
  106. }
  107.  
  108. sub MakeStruct {
  109.     my($self, $n, $addr) = @_;    
  110.     DEBUG "(PM)Win32::API::Callback::MakeStruct: got self='$self'\n";
  111.     my $struct = Win32::API::Struct->new($self->{intypes}->[$n]);    
  112.     $struct->FromMemory($addr);
  113.     return $struct;
  114. }
  115.  
  116. 1;
  117.  
  118. __END__
  119.  
  120. #######################################################################
  121. # DOCUMENTATION
  122. #
  123.  
  124. =head1 NAME
  125.  
  126. Win32::API::Callback - Callback support for Win32::API
  127.  
  128. =head1 SYNOPSIS
  129.  
  130.   use Win32::API;
  131.   use Win32::API::Callback;
  132.  
  133.   my $callback = Win32::API::Callback->new(
  134.     sub { my($a, $b) = @_; return $a+$b; },
  135.     "NN", "N",
  136.   );
  137.  
  138.   Win32::API->Import(
  139.       'mydll', 'two_integers_cb', 'KNN', 'N',
  140.   );
  141.  
  142.   $sum = two_integers_cb( $callback, 3, 2 );
  143.  
  144.  
  145. =head1 FOREWORDS
  146.  
  147. =over 4
  148.  
  149. =item *
  150. Support for this module is B<highly experimental> at this point.
  151.  
  152. =item *
  153. I won't be surprised if it doesn't work for you.
  154.  
  155. =item *
  156. Feedback is very appreciated.
  157.  
  158. =item *
  159. Documentation is in the work. Either see the SYNOPSIS above
  160. or the samples in the F<samples> directory.
  161.  
  162. =back
  163.  
  164. =head1 AUTHOR
  165.  
  166. Aldo Calpini ( I<dada@perl.it> ).
  167.  
  168. =cut
  169.  
  170.  
  171.