Commit | Line | Data |
ed344e4f |
1 | package OS2::DLL; |
2 | |
28b605d8 |
3 | our $VERSION = '1.00'; |
4 | |
ed344e4f |
5 | use Carp; |
6 | use DynaLoader; |
7 | |
8 | @ISA = qw(DynaLoader); |
9 | |
10 | sub AUTOLOAD { |
11 | $AUTOLOAD =~ /^OS2::DLL::.+::(.+)$/ |
12 | or confess("Undefined subroutine &$AUTOLOAD called"); |
13 | return undef if $1 eq "DESTROY"; |
14 | $_[0]->find($1) |
15 | or confess("Can't find entry '$1' to DLL '$_[0]->{File}': $^E"); |
16 | goto &$AUTOLOAD; |
17 | } |
18 | |
19 | @libs = split(/;/, $ENV{'PERL5REXX'} || $ENV{'PERLREXX'} || $ENV{'LIBPATH'} || $ENV{'PATH'}); |
20 | %dlls = (); |
21 | |
22 | # Preloaded methods go here. Autoload methods go after __END__, and are |
23 | # processed by the autosplit program. |
24 | |
25 | # Cannot autoload, the autoloader is used for the REXX functions. |
26 | |
a748068b |
27 | sub new { |
28 | confess 'Usage: OS2::DLL->new( <file> [<dirs>] )' unless @_ >= 2; |
29 | my ($class, $file) = (shift, shift); |
30 | my $handle; |
31 | $handle = $class->load($file, @_) and return $handle; |
32 | my $path = @_ ? " from '@_'" : ''; |
33 | my $err = DynaLoader::dl_error(); |
34 | $err =~ s/\s+at\s+\S+\s+line\s+\S+\s*\z//; |
35 | croak "Can't load '$file'$path: $err"; |
36 | } |
37 | |
ed344e4f |
38 | sub load |
39 | { |
40 | confess 'Usage: load OS2::DLL <file> [<dirs>]' unless $#_ >= 1; |
41 | my ($class, $file, @where) = (@_, @libs); |
42 | return $dlls{$file} if $dlls{$file}; |
43 | my $handle; |
44 | foreach (@where) { |
45 | $handle = DynaLoader::dl_load_file("$_/$file.dll"); |
46 | last if $handle; |
47 | } |
48 | $handle = DynaLoader::dl_load_file($file) unless $handle; |
49 | return undef unless $handle; |
50 | my $packs = $INC{'OS2/REXX.pm'} ? 'OS2::DLL OS2::REXX' : 'OS2::DLL'; |
51 | eval <<EOE or die "eval package $@"; |
52 | package OS2::DLL::$file; \@ISA = qw($packs); |
53 | sub AUTOLOAD { |
54 | \$OS2::DLL::AUTOLOAD = \$AUTOLOAD; |
55 | goto &OS2::DLL::AUTOLOAD; |
56 | } |
57 | 1; |
58 | EOE |
59 | return $dlls{$file} = |
60 | bless {Handle => $handle, File => $file, Queue => 'SESSION' }, |
61 | "OS2::DLL::$file"; |
62 | } |
63 | |
64 | sub find |
65 | { |
66 | my $self = shift; |
67 | my $file = $self->{File}; |
68 | my $handle = $self->{Handle}; |
69 | my $prefix = exists($self->{Prefix}) ? $self->{Prefix} : ""; |
70 | my $queue = $self->{Queue}; |
71 | foreach (@_) { |
72 | my $name = "OS2::DLL::${file}::$_"; |
73 | next if defined(&$name); |
74 | my $addr = DynaLoader::dl_find_symbol($handle, uc $prefix.$_) |
75 | || DynaLoader::dl_find_symbol($handle, $prefix.$_) |
76 | or return 0; |
77 | eval <<EOE or die "eval sub"; |
78 | package OS2::DLL::$file; |
79 | sub $_ { |
80 | shift; |
81 | OS2::DLL::_call('$_', $addr, '$queue', \@_); |
82 | } |
83 | 1; |
84 | EOE |
85 | } |
86 | return 1; |
87 | } |
88 | |
89 | bootstrap OS2::DLL; |
90 | |
91 | 1; |
92 | __END__ |
93 | |
94 | =head1 NAME |
95 | |
96 | OS2::DLL - access to DLLs with REXX calling convention. |
97 | |
98 | =head2 NOTE |
99 | |
100 | When you use this module, the REXX variable pool is not available. |
101 | |
102 | See documentation of L<OS2::REXX> module if you need the variable pool. |
103 | |
104 | =head1 SYNOPSIS |
105 | |
106 | use OS2::DLL; |
107 | $emx_dll = OS2::DLL->load('emx'); |
108 | $emx_version = $emx_dll->emx_revision(); |
109 | |
110 | =head1 DESCRIPTION |
111 | |
112 | =head2 Load REXX DLL |
113 | |
114 | $dll = load OS2::DLL NAME [, WHERE]; |
115 | |
116 | NAME is DLL name, without path and extension. |
117 | |
118 | Directories are searched WHERE first (list of dirs), then environment |
119 | paths PERL5REXX, PERLREXX, PATH or, as last resort, OS/2-ish search |
120 | is performed in default DLL path (without adding paths and extensions). |
121 | |
122 | The DLL is not unloaded when the variable dies. |
123 | |
a748068b |
124 | Returns DLL object reference, or undef on failure (in this case one can |
125 | get the reason via C<DynaLoader::dl_error()>). |
126 | |
127 | =head2 Create a REXX DLL handle |
128 | |
129 | $dll = OS2::DLL->new( NAME [, WHERE] ); |
130 | |
131 | Same as L<C<load>|Load REXX DLL>, but croaks with a meaningful message on |
132 | failure. |
ed344e4f |
133 | |
134 | =head2 Check for functions (optional): |
135 | |
136 | BOOL = $dll->find(NAME [, NAME [, ...]]); |
137 | |
138 | Returns true if all functions are available. |
139 | |
140 | =head2 Call external REXX function: |
141 | |
142 | $dll->function(arguments); |
143 | |
144 | Returns the return string if the return code is 0, else undef. |
145 | Dies with error message if the function is not available. |
146 | |
147 | =head1 ENVIRONMENT |
148 | |
149 | If C<PERL_REXX_DEBUG> is set, emits debugging output. Looks for DLLs |
150 | in C<PERL5REXX>, C<PERLREXX>, C<PATH>. |
151 | |
152 | =head1 AUTHOR |
153 | |
154 | Extracted by Ilya Zakharevich ilya@math.ohio-state.edu from L<OS2::REXX> |
155 | written by Andreas Kaiser ak@ananke.s.bawue.de. |
156 | |
157 | =cut |