Commit | Line | Data |
---|---|---|
4ceeac64 AB |
1 | package Amiga::ARexx; |
2 | ||
3 | use 5.016000; | |
4 | use strict; | |
5 | use warnings; | |
6 | use Carp; | |
7 | ||
8 | require Exporter; | |
9 | #use AutoLoader; | |
10 | ||
11 | our @ISA = qw(Exporter); | |
12 | ||
13 | # Items to export into callers namespace by default. Note: do not export | |
14 | # names by default without a very good reason. Use EXPORT_OK instead. | |
15 | # Do not simply export all your public functions/methods/constants. | |
16 | ||
17 | # This allows declaration use Amiga::Classes::ARexx ':all'; | |
18 | # If you do not need this, moving things directly into @EXPORT or @EXPORT_OK | |
19 | # will save memory. | |
20 | our %EXPORT_TAGS = ( 'all' => [ qw( | |
21 | DoRexx | |
22 | ) ] ); | |
23 | ||
24 | our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); | |
25 | ||
26 | our @EXPORT = qw( | |
27 | ); | |
28 | ||
e46aa1dd | 29 | our $VERSION = '0.04'; |
4ceeac64 AB |
30 | |
31 | require XSLoader; | |
32 | XSLoader::load('Amiga::ARexx', $VERSION); | |
33 | ||
34 | sub new | |
35 | { | |
36 | my $class = shift; | |
37 | my $self = bless {}, $class; | |
38 | return $self->__init(@_); | |
39 | } | |
40 | ||
41 | sub __init | |
42 | { | |
43 | my $self = shift; | |
44 | my %params = @_; | |
45 | my @tags = (); | |
46 | ||
47 | if(exists $params{'HostName'}) | |
48 | { | |
49 | $self->{'__hostname'} = $params{'HostName'}; | |
50 | } else { croak "HostName required";} | |
51 | ||
52 | $self->{'__host'} = Amiga::ARexx::Host_init($self->{'__hostname'}); | |
53 | if (defined $self->{'__host'} && $self->{'__host'} != 0) | |
54 | { | |
55 | } | |
56 | else | |
57 | { | |
58 | croak "Unabel to initialise Arexx Host"; | |
59 | } | |
60 | return $self; | |
61 | } | |
62 | ||
63 | sub wait | |
64 | { | |
65 | my $self = shift; | |
66 | my %params = @_; | |
67 | my $timeout = -1; | |
68 | if ((exists $params{'TimeOut'}) && (defined $params{'TimeOut'})) | |
69 | { | |
70 | $timeout = $params{'TimeOut'}; | |
71 | $timeout += 0; # force number | |
72 | } | |
73 | Amiga::ARexx::Host_wait($self->{'__host'},$timeout); | |
74 | ||
75 | } | |
76 | ||
77 | sub signal | |
78 | { | |
79 | my $self = shift; | |
80 | return Amiga::ARexx::Host_signal($self->{'__host'}); | |
81 | } | |
82 | ||
83 | sub getmsg | |
84 | { | |
85 | my $self = shift; | |
86 | my $msg; | |
87 | my $msgobj; | |
88 | ||
89 | if(defined $self->{'__host'}) | |
90 | { | |
91 | $msg = Amiga::ARexx::Host_getmsg($self->{'__host'}); | |
92 | if($msg) | |
93 | { | |
94 | $msgobj = Amiga::ARexx::Msg->new('Message' => $msg); | |
95 | } | |
96 | } | |
97 | return $msgobj; | |
98 | } | |
99 | ||
100 | sub DESTROY | |
101 | { | |
102 | my $self = shift; | |
103 | if(exists $self->{'__host'} && defined $self->{'__host'}) | |
104 | { | |
105 | Amiga::ARexx::Host_delete($self->{'__host'}); | |
106 | delete $self->{'__host'}; | |
107 | } | |
108 | } | |
109 | ||
110 | sub DoRexx($$) | |
111 | { | |
112 | my ($port,$command) = @_; | |
113 | my $rc = 0; | |
114 | my $rc2 = 0; | |
115 | my $result = Amiga::ARexx::_DoRexx($port,$command,$rc,$rc2); | |
116 | return ($rc,$rc2,$result); | |
117 | } | |
118 | ||
119 | package Amiga::ARexx::Msg; | |
120 | ||
121 | use strict; | |
122 | use warnings; | |
123 | use Carp; | |
124 | ||
125 | sub new | |
126 | { | |
127 | my $class = shift; | |
128 | my $self = bless {}, $class; | |
129 | return $self->__init(@_); | |
130 | } | |
131 | ||
132 | sub __init | |
133 | { | |
134 | my $self = shift; | |
135 | my %params = @_; | |
136 | ||
137 | if(exists $params{'Message'}) | |
138 | { | |
139 | $self->{'__msg'} = $params{'Message'}; | |
140 | } else { croak "Message required";} | |
141 | ||
142 | $self->{'__message'} = Amiga::ARexx::Msg_argstr($self->{'__msg'}); | |
143 | return $self; | |
144 | } | |
145 | ||
146 | sub message | |
147 | { | |
148 | my $self = shift; | |
149 | return $self->{'__message'}; | |
150 | } | |
151 | ||
152 | sub reply($$$$) | |
153 | { | |
154 | my ($self,$rc,$rc2,$result) = @_; | |
155 | if(exists $self->{'__msg'} && defined $self->{'__msg'}) | |
156 | { | |
157 | Amiga::ARexx::Msg_reply($self->{'__msg'},$rc,$rc2,$result); | |
158 | } | |
159 | } | |
160 | ||
161 | sub setvar($$$) | |
162 | { | |
163 | my ($self,$varname,$value) = @_; | |
164 | if(exists $self->{'__msg'} && defined $self->{'__msg'}) | |
165 | { | |
166 | Amiga::ARexx::Msg_setvar($self->{'__msg'},$varname,$value); | |
167 | } | |
168 | } | |
169 | ||
170 | sub getvar($$) | |
171 | { | |
172 | my ($self,$varname) = @_; | |
173 | if(exists $self->{'__msg'} && defined $self->{'__msg'}) | |
174 | { | |
175 | return Amiga::ARexx::Msg_getvar($self->{'__msg'},$varname); | |
176 | } | |
177 | } | |
178 | ||
179 | sub DESTROY | |
180 | { | |
181 | my $self = shift; | |
182 | if(exists $self->{'__msg'} && defined $self->{'__msg'}) | |
183 | { | |
184 | Amiga::ARexx::Msg_delete($self->{'__msg'}); | |
185 | delete $self->{'__msg'}; | |
186 | } | |
187 | } | |
188 | ||
189 | # Preloaded methods go here. | |
190 | ||
191 | # Autoload methods go after =cut, and are processed by the autosplit program. | |
192 | ||
193 | 1; | |
194 | __END__ | |
195 | # Below is stub documentation for your module. You'd better edit it! | |
196 | ||
197 | =head1 NAME | |
198 | ||
199 | Amiga::ARexx - Perl extension for ARexx support | |
200 | ||
201 | =head1 ABSTRACT | |
202 | ||
203 | This a perl class / module to enable you to use ARexx with | |
204 | your perlscript. Creating a function host or executing scripts in other hosts. | |
205 | The API is loosley modeled on the python arexx module supplied by with AmigaOS4.1 | |
206 | ||
207 | =head1 SYNOPSIS | |
208 | ||
209 | # Create a new host | |
210 | ||
211 | use Amiga::ARexx; | |
e46aa1dd | 212 | my $host = Amiga::ARexx->new('HostName' => "PERLREXX" ); |
4ceeac64 AB |
213 | |
214 | # Wait for and process rexxcommands | |
215 | ||
216 | my $alive = 1; | |
217 | ||
218 | while ($alive) | |
219 | { | |
220 | $host->wait(); | |
221 | my $msg = $host->getmsg(); | |
222 | while($msg) | |
223 | { | |
224 | my $rc = 0; | |
225 | my $rc2 = 0; | |
226 | my $result = ""; | |
227 | ||
228 | print $msg->message . "\n"; | |
229 | given($msg->message) | |
230 | { | |
231 | when ("QUIT") | |
232 | { | |
233 | $alive = 0; | |
234 | $result = "quitting!"; | |
235 | } | |
236 | default { | |
237 | $rc = 10; | |
238 | $rc2 = 22; | |
239 | } | |
240 | } | |
241 | $msg->reply($rc,$rc2,$result); | |
242 | ||
243 | $msg = $host->getmsg(); | |
244 | } | |
245 | ||
246 | } | |
247 | ||
248 | # Send a command to a host | |
249 | ||
250 | my $port = "SOMEHOST"; | |
251 | my $command = "SOMECOMMAND"; | |
252 | my ($rc,$rc2,$result) = Amiga::ARexx->DoRexx($port,$command); | |
253 | ||
254 | ||
255 | ||
256 | =head1 DESCRIPTION | |
257 | ||
258 | The interface to the arexx.class in entirely encapsulated within the perl class, there | |
259 | is no need to access the low level methods directly and they are not exported by default. | |
260 | ||
261 | =head1 Amiga::ARexx METHODS | |
262 | ||
263 | =head2 new | |
264 | ||
e46aa1dd | 265 | my $host = Amiga::ARexx->new( HostName => "PERLREXX"); |
4ceeac64 AB |
266 | |
267 | ||
268 | Create an ARexx host for your script / program. | |
269 | ||
270 | =head3 HostName | |
271 | ||
272 | The HostName for the hosts command port. This is madatory, the program will fail if not | |
273 | provided. | |
274 | ||
275 | ||
276 | =head2 wait | |
277 | ||
278 | $host->wait('TimeOut' => $timeoutinusecs ); | |
279 | ||
280 | Wait for a message to arive at the port. | |
281 | ||
282 | =head3 TimeOut | |
283 | ||
284 | optional time out in microseconds. | |
285 | ||
286 | ||
287 | =head2 getmsg | |
288 | ||
289 | $msg = $host->getmsg(); | |
290 | ||
291 | ||
292 | Fetch an ARexx message from the host port. Returns an objrct of class Amiga::ARexx::Msg | |
293 | ||
294 | =head2 signal | |
295 | ||
296 | $signal = $host->signal() | |
297 | ||
298 | Retrieve the signal mask for the host port for use with Amiga::Exec Wait() | |
299 | ||
300 | =head2 DoRexx | |
301 | ||
302 | ($rc,$rc2,$result) = DoRexx("desthost","commandstring"); | |
303 | ||
304 | Send the "commandstring" to host "desthost" for execution. Commandstring might be a specific command or scriptname. | |
305 | ||
306 | =head1 Amiga::ARexx::Msg METHODS | |
307 | ||
308 | =head2 message | |
309 | ||
310 | $m = $msg->message(); | |
311 | ||
312 | Retreive the message "command" as a string; | |
313 | ||
314 | ||
315 | =head2 reply | |
316 | ||
317 | $msg->reply($rc,$rc2,$result) | |
318 | ||
319 | Reply the message returning the results of any command. Set $rc = 0 for success and $result to the result string if appropriate. | |
320 | ||
321 | Set $rc to non zero for error and $rc2 for an additional error code if appropriate. | |
322 | ||
323 | =head2 setvar | |
324 | ||
325 | $msg->setvar($varname,$value) | |
326 | ||
327 | Set a variable in the language context sending this message. | |
328 | ||
329 | =head2 getvar | |
330 | ||
331 | $value = $msg->getvar($varname) | |
332 | ||
333 | Get the value of a variable in the language context sending this message. | |
334 | ||
335 | ||
336 | =head2 EXPORT | |
337 | ||
338 | None by default. | |
339 | ||
340 | =head2 Exportable constants | |
341 | ||
342 | None | |
343 | ||
344 | =head1 AUTHOR | |
345 | ||
346 | Andy Broad <andy@broad.ology.org.uk> | |
347 | ||
348 | =head1 COPYRIGHT AND LICENSE | |
349 | ||
350 | Copyright (C) 2013 by Andy Broad. | |
351 | ||
352 | =cut | |
353 | ||
354 | ||
355 |