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.04';
  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