This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
amigaos4: add Amiga::ARexx and Amiga::Exec
[perl5.git] / ext / Amiga-ARexx / ARexx.pm
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
29 our $VERSION = '0.02';
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;
212     my $host = Amiga::ARexx->new('HostName' => "PERLREXX" );                                                                          );
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
265     my $host = Amiga::ARexx->new( HostName => "PERLREXX");                                                                            );
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