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