embed.fnc Database used by embed.pl
embed.h Maps symbols to safer names
embedvar.h C namespace management
+ext/Amiga-ARexx/ARexx.pm Amiga::ARexx extension
+ext/Amiga-ARexx/ARexx.xs Amiga::ARexx extension
+ext/Amiga-ARexx/__examples/simplecommand.pl Amiga::ARexx extension
+ext/Amiga-ARexx/__examples/simplehost.pl Amiga::ARexx extension
+ext/Amiga-ARexx/Makefile.PL Amiga::ARexx extension
+ext/Amiga-ARexx/tagtypes.h Amiga::ARexx extension
+ext/Amiga-ARexx/typemap Amiga::ARexx extension
+ext/Amiga-Exec/__examples/simplecommand.pl Amiga::Exec extension
+ext/Amiga-Exec/__examples/simplehost.pl Amiga::Exec extension
+ext/Amiga-Exec/Exec.pm Amiga::Exec extension
+ext/Amiga-Exec/Exec.xs Amiga::Exec extension
+ext/Amiga-Exec/Makefile.PL Amiga::Exec extension
+ext/Amiga-Exec/tagtypes.h Amiga::Exec extension
+ext/Amiga-Exec/typemap Amiga::Exec extension
ext/arybase/arybase.pm For $[
ext/arybase/arybase.xs For $[
ext/arybase/ptable.h For $[
--- /dev/null
+package Amiga::ARexx;
+
+use 5.016000;
+use strict;
+use warnings;
+use Carp;
+
+require Exporter;
+#use AutoLoader;
+
+our @ISA = qw(Exporter);
+
+# Items to export into callers namespace by default. Note: do not export
+# names by default without a very good reason. Use EXPORT_OK instead.
+# Do not simply export all your public functions/methods/constants.
+
+# This allows declaration use Amiga::Classes::ARexx ':all';
+# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
+# will save memory.
+our %EXPORT_TAGS = ( 'all' => [ qw(
+DoRexx
+) ] );
+
+our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
+
+our @EXPORT = qw(
+);
+
+our $VERSION = '0.02';
+
+require XSLoader;
+XSLoader::load('Amiga::ARexx', $VERSION);
+
+sub new
+{
+ my $class = shift;
+ my $self = bless {}, $class;
+ return $self->__init(@_);
+}
+
+sub __init
+{
+ my $self = shift;
+ my %params = @_;
+ my @tags = ();
+
+ if(exists $params{'HostName'})
+ {
+ $self->{'__hostname'} = $params{'HostName'};
+ } else { croak "HostName required";}
+
+ $self->{'__host'} = Amiga::ARexx::Host_init($self->{'__hostname'});
+ if (defined $self->{'__host'} && $self->{'__host'} != 0)
+ {
+ }
+ else
+ {
+ croak "Unabel to initialise Arexx Host";
+ }
+ return $self;
+}
+
+sub wait
+{
+ my $self = shift;
+ my %params = @_;
+ my $timeout = -1;
+ if ((exists $params{'TimeOut'}) && (defined $params{'TimeOut'}))
+ {
+ $timeout = $params{'TimeOut'};
+ $timeout += 0; # force number
+ }
+ Amiga::ARexx::Host_wait($self->{'__host'},$timeout);
+
+}
+
+sub signal
+{
+ my $self = shift;
+ return Amiga::ARexx::Host_signal($self->{'__host'});
+}
+
+sub getmsg
+{
+ my $self = shift;
+ my $msg;
+ my $msgobj;
+
+ if(defined $self->{'__host'})
+ {
+ $msg = Amiga::ARexx::Host_getmsg($self->{'__host'});
+ if($msg)
+ {
+ $msgobj = Amiga::ARexx::Msg->new('Message' => $msg);
+ }
+ }
+ return $msgobj;
+}
+
+sub DESTROY
+{
+ my $self = shift;
+ if(exists $self->{'__host'} && defined $self->{'__host'})
+ {
+ Amiga::ARexx::Host_delete($self->{'__host'});
+ delete $self->{'__host'};
+ }
+}
+
+sub DoRexx($$)
+{
+ my ($port,$command) = @_;
+ my $rc = 0;
+ my $rc2 = 0;
+ my $result = Amiga::ARexx::_DoRexx($port,$command,$rc,$rc2);
+ return ($rc,$rc2,$result);
+}
+
+package Amiga::ARexx::Msg;
+
+use strict;
+use warnings;
+use Carp;
+
+sub new
+{
+ my $class = shift;
+ my $self = bless {}, $class;
+ return $self->__init(@_);
+}
+
+sub __init
+{
+ my $self = shift;
+ my %params = @_;
+
+ if(exists $params{'Message'})
+ {
+ $self->{'__msg'} = $params{'Message'};
+ } else { croak "Message required";}
+
+ $self->{'__message'} = Amiga::ARexx::Msg_argstr($self->{'__msg'});
+ return $self;
+}
+
+sub message
+{
+ my $self = shift;
+ return $self->{'__message'};
+}
+
+sub reply($$$$)
+{
+ my ($self,$rc,$rc2,$result) = @_;
+ if(exists $self->{'__msg'} && defined $self->{'__msg'})
+ {
+ Amiga::ARexx::Msg_reply($self->{'__msg'},$rc,$rc2,$result);
+ }
+}
+
+sub setvar($$$)
+{
+ my ($self,$varname,$value) = @_;
+ if(exists $self->{'__msg'} && defined $self->{'__msg'})
+ {
+ Amiga::ARexx::Msg_setvar($self->{'__msg'},$varname,$value);
+ }
+}
+
+sub getvar($$)
+{
+ my ($self,$varname) = @_;
+ if(exists $self->{'__msg'} && defined $self->{'__msg'})
+ {
+ return Amiga::ARexx::Msg_getvar($self->{'__msg'},$varname);
+ }
+}
+
+sub DESTROY
+{
+ my $self = shift;
+ if(exists $self->{'__msg'} && defined $self->{'__msg'})
+ {
+ Amiga::ARexx::Msg_delete($self->{'__msg'});
+ delete $self->{'__msg'};
+ }
+}
+
+# Preloaded methods go here.
+
+# Autoload methods go after =cut, and are processed by the autosplit program.
+
+1;
+__END__
+# Below is stub documentation for your module. You'd better edit it!
+
+=head1 NAME
+
+Amiga::ARexx - Perl extension for ARexx support
+
+=head1 ABSTRACT
+
+This a perl class / module to enable you to use ARexx with
+your perlscript. Creating a function host or executing scripts in other hosts.
+The API is loosley modeled on the python arexx module supplied by with AmigaOS4.1
+
+=head1 SYNOPSIS
+
+ # Create a new host
+
+ use Amiga::ARexx;
+ my $host = Amiga::ARexx->new('HostName' => "PERLREXX" ); );
+
+ # Wait for and process rexxcommands
+
+ my $alive = 1;
+
+ while ($alive)
+ {
+ $host->wait();
+ my $msg = $host->getmsg();
+ while($msg)
+ {
+ my $rc = 0;
+ my $rc2 = 0;
+ my $result = "";
+
+ print $msg->message . "\n";
+ given($msg->message)
+ {
+ when ("QUIT")
+ {
+ $alive = 0;
+ $result = "quitting!";
+ }
+ default {
+ $rc = 10;
+ $rc2 = 22;
+ }
+ }
+ $msg->reply($rc,$rc2,$result);
+
+ $msg = $host->getmsg();
+ }
+
+ }
+
+ # Send a command to a host
+
+ my $port = "SOMEHOST";
+ my $command = "SOMECOMMAND";
+ my ($rc,$rc2,$result) = Amiga::ARexx->DoRexx($port,$command);
+
+
+
+=head1 DESCRIPTION
+
+The interface to the arexx.class in entirely encapsulated within the perl class, there
+is no need to access the low level methods directly and they are not exported by default.
+
+=head1 Amiga::ARexx METHODS
+
+=head2 new
+
+ my $host = Amiga::ARexx->new( HostName => "PERLREXX"); );
+
+
+Create an ARexx host for your script / program.
+
+=head3 HostName
+
+The HostName for the hosts command port. This is madatory, the program will fail if not
+provided.
+
+
+=head2 wait
+
+ $host->wait('TimeOut' => $timeoutinusecs );
+
+Wait for a message to arive at the port.
+
+=head3 TimeOut
+
+optional time out in microseconds.
+
+
+=head2 getmsg
+
+ $msg = $host->getmsg();
+
+
+Fetch an ARexx message from the host port. Returns an objrct of class Amiga::ARexx::Msg
+
+=head2 signal
+
+ $signal = $host->signal()
+
+Retrieve the signal mask for the host port for use with Amiga::Exec Wait()
+
+=head2 DoRexx
+
+ ($rc,$rc2,$result) = DoRexx("desthost","commandstring");
+
+Send the "commandstring" to host "desthost" for execution. Commandstring might be a specific command or scriptname.
+
+=head1 Amiga::ARexx::Msg METHODS
+
+=head2 message
+
+ $m = $msg->message();
+
+Retreive the message "command" as a string;
+
+
+=head2 reply
+
+ $msg->reply($rc,$rc2,$result)
+
+Reply the message returning the results of any command. Set $rc = 0 for success and $result to the result string if appropriate.
+
+Set $rc to non zero for error and $rc2 for an additional error code if appropriate.
+
+=head2 setvar
+
+ $msg->setvar($varname,$value)
+
+Set a variable in the language context sending this message.
+
+=head2 getvar
+
+ $value = $msg->getvar($varname)
+
+Get the value of a variable in the language context sending this message.
+
+
+=head2 EXPORT
+
+None by default.
+
+=head2 Exportable constants
+
+None
+
+=head1 AUTHOR
+
+Andy Broad <andy@broad.ology.org.uk>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2013 by Andy Broad.
+
+=cut
+
+
+
--- /dev/null
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#include "ppport.h"
+
+#undef __USE_INLINE__
+#include <exec/types.h>
+#include <utility/tagitem.h>
+#include <proto/exec.h>
+#include <proto/intuition.h>
+#include <proto/rexxsyslib.h>
+#include <proto/utility.h>
+
+#include <rexx/rxslib.h>
+#include <rexx/errors.h>
+//#include "rexxmsgext.h" // this should change depening on the ultimate location of the structures
+
+/* utils */
+
+/*
+ * Structure for the rexx host. Most of the code is inspired from Olaf
+ * Barthel's sample ARexx code from the developer CD 2.1
+ */
+
+
+struct RexxHost
+{
+ struct MsgPort *Port;
+ TEXT PortName[81];
+} ;
+
+struct ARexxMsg
+{
+ struct RexxMsg *rexxMsg;
+ BOOL isReplied;
+ struct RexxHost *rexxHost;
+};
+
+STRPTR dupstr(STRPTR src)
+{
+ STRPTR dest = NULL;
+ ULONG len;
+ if(src)
+ {
+ len = strlen(src);
+ if((dest = IExec->AllocVec(len + 1, MEMF_ANY)))
+ {
+ strcpy(dest,src);
+ }
+ }
+ return dest;
+}
+
+
+struct TimeRequest *
+OpenTimer(void)
+{
+ struct MsgPort *port = IExec->AllocSysObjectTags(ASOT_PORT, TAG_END);
+ if (port == NULL)
+ {
+ return NULL;
+ }
+
+ struct TimeRequest *req = IExec->AllocSysObjectTags(ASOT_IOREQUEST,
+ ASOIOR_Size, sizeof(struct TimeRequest),
+ ASOIOR_ReplyPort, port,
+ TAG_END);
+
+ if (req == NULL)
+ {
+ IExec->FreeSysObject(ASOT_PORT, port);
+ return NULL;
+ }
+
+ int8 deverr = IExec->OpenDevice("timer.device", UNIT_MICROHZ,
+ &req->Request, 0);
+
+ if (deverr != IOERR_SUCCESS)
+ {
+ IExec->FreeSysObject(ASOT_IOREQUEST, req);
+ IExec->FreeSysObject(ASOT_PORT, port);
+ return NULL;
+ }
+
+ return req;
+}
+
+
+void
+CloseTimer(struct TimeRequest *req)
+{
+ if (req != NULL)
+ {
+ struct MsgPort *port = req->Request.io_Message.mn_ReplyPort;
+
+ IExec->CloseDevice(&req->Request);
+ IExec->FreeSysObject(ASOT_IOREQUEST, req);
+ IExec->FreeSysObject(ASOT_PORT, port);
+ }
+}
+
+LONG
+ReturnRexxMsg(struct RexxMsg * Message, CONST_STRPTR Result)
+{
+ STRPTR ResultString = NULL;
+
+ /* No error has occured yet. */
+ int32 ErrorCode = 0;
+
+ /* Set up the RexxMsg to return no error. */
+ Message->rm_Result1 = RC_OK;
+ Message->rm_Result2 = 0;
+
+ /* Check if the command should return a result. */
+ if((Message->rm_Action & RXFF_RESULT) && Result != NULL)
+ {
+ /* To return the result string we need to make
+ * a copy for ARexx to use.
+ */
+ if((ResultString = IRexxSys->CreateArgstring(Result, strlen(Result))))
+ {
+ /* Put the string into the secondary
+ * result field.
+ */
+ Message->rm_Result2 = (LONG)ResultString;
+ }
+ else
+ {
+ /* No memory available. */
+ ErrorCode = ERR10_003;
+ }
+ }
+
+ /* Reply the message, regardless of the error code. */
+ IExec->ReplyMsg((struct Message *)Message);
+
+ return(ErrorCode);
+}
+
+
+void
+ReturnErrorMsg(struct RexxMsg *msg, CONST_STRPTR port, int32 rc, int32 rc2)
+{
+ /* To signal an error the rc_Result1
+ * entry of the RexxMsg needs to be set to
+ * RC_ERROR. Unfortunately, we cannot convey
+ * the more meaningful error code through
+ * this interface which is why we set a
+ * Rexx variable to the error number. The
+ * Rexx script can then take a look at this
+ * variable and decide which further steps
+ * it should take.
+ */
+ msg->rm_Result1 = rc;
+ msg->rm_Result2 = rc2;
+
+ /* Turn the error number into a string as
+ * ARexx only deals with strings.
+ */
+ char value[12];
+ IUtility->SNPrintf(value, sizeof(value), "%ld", rc2);
+
+ /* Build the name of the variable to set to
+ * the error number. We will use the name of
+ * the host name and append ".LASTERROR".
+ */
+ IRexxSys->SetRexxVarFromMsg("RC2", value, msg);
+
+ IExec->ReplyMsg(&msg->rm_Node);
+}
+
+BOOL
+PutMsgTo(CONST_STRPTR name, struct Message *msg)
+{
+ BOOL done = FALSE;
+
+ IExec->Forbid();
+
+ struct MsgPort *port = IExec->FindPort(name);
+ if (port != NULL)
+ {
+ IExec->PutMsg(port, msg);
+ done = TRUE;
+ }
+
+ IExec->Permit();
+
+ return done;
+}
+
+
+STRPTR DoRexx(STRPTR port, STRPTR command, int32 *rc, int32 *rc2)
+{
+ *rc = 0;
+ *rc2 = 0;
+ STRPTR result = NULL;
+ STRPTR dup = NULL;
+
+ struct MsgPort *replyPort = IExec->AllocSysObjectTags(ASOT_PORT, TAG_END);
+ if (replyPort == NULL)
+ {
+ return NULL;
+ }
+
+ struct RexxMsg *rexxMsg = IRexxSys->CreateRexxMsg(replyPort, NULL, NULL);
+ ((struct Node *)rexxMsg)->ln_Name = "REXX";
+ if (rexxMsg == NULL)
+ {
+ IExec->FreeSysObject(ASOT_PORT, replyPort);
+ return NULL;
+ }
+ BOOL sent = FALSE;
+
+
+ rexxMsg->rm_Args[0] = IRexxSys->CreateArgstring(command, strlen(command));
+
+ if (rexxMsg->rm_Args[0] != NULL)
+ {
+ rexxMsg->rm_Action = RXCOMM | RXFF_RESULT | RXFF_STRING;
+
+ sent = PutMsgTo(port, (struct Message*)rexxMsg);
+
+ if (sent)
+ {
+ IExec->WaitPort(replyPort);
+ (void)IExec->GetMsg(replyPort);
+ }
+ else
+ {
+
+ }
+
+ *rc = rexxMsg->rm_Result1;
+
+ if (*rc == RC_OK)
+ {
+ if (rexxMsg->rm_Result2 != 0)
+ {
+ result = (STRPTR)rexxMsg->rm_Result2;
+ }
+ }
+ else
+ {
+ *rc2 = rexxMsg->rm_Result2;
+ }
+
+ IRexxSys->DeleteArgstring(rexxMsg->rm_Args[0]);
+ rexxMsg->rm_Args[0] = NULL;
+ }
+
+ IRexxSys->DeleteRexxMsg(rexxMsg);
+ rexxMsg = NULL;
+
+ IExec->FreeSysObject(ASOT_PORT, replyPort);
+ replyPort = NULL;
+
+ if (result != NULL)
+ {
+ dup = dupstr(result);
+
+ IRexxSys->DeleteArgstring(result);
+ result = NULL;
+ }
+
+ return dup;
+}
+
+
+struct RexxHost *CreateRexxHost(CONST_STRPTR PortName)
+{
+ struct RexxHost *newHost = IExec->AllocVecTags(sizeof(struct RexxHost),
+ AVT_Type, MEMF_PRIVATE, AVT_ClearWithValue, 0, TAG_DONE);
+
+ if (newHost == NULL)
+ {
+ return NULL;
+ }
+
+ IUtility->Strlcpy(newHost->PortName, PortName, sizeof(newHost->PortName));
+
+ IExec->Forbid();
+
+ /* Check if the name already exists */
+ if (IExec->FindPort(PortName) != NULL)
+ {
+ int32 index = 1;
+ do
+ {
+ IUtility->SNPrintf(newHost->PortName, sizeof(newHost->PortName), "%s.%ld", PortName, index);
+ index++;
+
+ if (IExec->FindPort(newHost->PortName) == NULL)
+ {
+ break;
+ }
+ } while (1);
+ }
+
+ newHost->Port = IExec->AllocSysObjectTags(ASOT_PORT,
+ ASOPORT_Name, newHost->PortName,
+ ASOPORT_Public, TRUE,
+ TAG_DONE);
+
+ IExec->Permit();
+
+ if (newHost->Port == NULL)
+ {
+ IExec->FreeVec(newHost);
+ return NULL;
+ }
+
+ return newHost;
+}
+
+
+void DeleteRexxHost(struct RexxHost *host)
+{
+ if (host)
+ {
+ if (host->Port)
+ {
+ struct RexxMsg *msg;
+
+ IExec->Forbid();
+ while ((msg = (struct RexxMsg *)IExec->GetMsg(host->Port)) != NULL)
+ {
+ msg->rm_Result1 = RC_FATAL;
+ IExec->ReplyMsg((struct Message *)msg);
+ }
+
+ IExec->FreeSysObject(ASOT_PORT, host->Port);
+ IExec->Permit();
+ }
+
+ IExec->FreeVec(host);
+ }
+}
+
+void WaitRexxHost(struct RexxHost *rexxHost, int timeout)
+{
+
+ struct TimeRequest *req = NULL;
+ uint32 timermask = 0;
+
+ if (timeout > 0)
+ {
+ req = OpenTimer();
+
+ if (req != NULL)
+ {
+ timermask = 1L << req->Request.io_Message.mn_ReplyPort->mp_SigBit;
+
+ req->Request.io_Command = TR_ADDREQUEST;
+ req->Time.Seconds = 0;
+ req->Time.Microseconds = timeout;
+
+ IExec->SendIO(&req->Request);
+ }
+ }
+
+ uint32 hostmask = 1L << rexxHost->Port->mp_SigBit;
+ uint32 waitmask = timermask | hostmask | SIGBREAKF_CTRL_C;
+
+ uint32 sigmask = IExec->Wait(waitmask);
+
+ if (req != NULL)
+ {
+ IExec->AbortIO(&req->Request);
+ IExec->WaitIO(&req->Request);
+ CloseTimer(req);
+ }
+
+ if (sigmask & SIGBREAKF_CTRL_C)
+ {
+ return;
+ }
+
+
+}
+
+struct ARexxMsg *GetMsgRexxHost(struct RexxHost *rexxHost)
+{
+ struct ARexxMsg *am = NULL;
+
+ struct RexxMsg *rexxMsg = NULL;
+
+ rexxMsg = (struct RexxMsg *)IExec->GetMsg(rexxHost->Port);
+ if (rexxMsg != NULL)
+ {
+ if((am = IExec->AllocVecTags(sizeof(struct ARexxMsg),AVT_Type, MEMF_PRIVATE, AVT_ClearWithValue, 0, TAG_DONE)))
+ {
+ am->rexxMsg = rexxMsg;
+ am->rexxHost = rexxHost;
+ am->isReplied = FALSE;
+ }
+
+ }
+ return am;
+}
+
+uint32 GetSignalRexxHost(struct RexxHost *rexxHost)
+{
+ return rexxHost->Port->mp_SigBit;
+}
+
+
+void ReplyARexxMsg(struct ARexxMsg *am, int rc, int rc2, STRPTR result)
+{
+ if(am)
+ {
+ if(!am->isReplied)
+ {
+ if(rc == 0)
+ {
+ ReturnRexxMsg(am->rexxMsg, result);
+ }
+ else
+ {
+ ReturnErrorMsg(am->rexxMsg, am->rexxHost->PortName,rc,rc2);
+ }
+ am->isReplied = TRUE;
+ }
+ }
+}
+
+STRPTR GetVarARexxMsg(struct ARexxMsg *am, STRPTR varname)
+{
+ STRPTR result = IExec->AllocVecTags(256,AVT_Type, MEMF_PRIVATE, AVT_ClearWithValue, 0, TAG_DONE);
+ if(result)
+ {
+ IRexxSys->GetRexxVarFromMsg(varname, result, am->rexxMsg);
+ }
+ return result;
+}
+
+void SetVarARexxMsg(struct ARexxMsg *am, STRPTR varname, STRPTR value)
+{
+ IRexxSys->SetRexxVarFromMsg(varname, value, am->rexxMsg);
+}
+
+void DeleteARexxMsg(struct ARexxMsg *am)
+{
+ if(!am->isReplied)
+ {
+ IExec->ReplyMsg(&am->rexxMsg->rm_Node);
+ am->isReplied = TRUE;
+ }
+ IExec->FreeVec(am);
+}
+
+STRPTR GetArgsARexxMsg(struct ARexxMsg *am)
+{
+ return am->rexxMsg->rm_Args[0];
+}
+
+MODULE = Amiga::ARexx PACKAGE = Amiga::ARexx
+
+PROTOTYPES: DISABLE
+
+
+APTR Host_init(name)
+ STRPTR name;
+ CODE:
+ RETVAL = CreateRexxHost(name);
+ OUTPUT:
+ RETVAL
+
+void Host_delete(rexxhost)
+ APTR rexxhost;
+ CODE:
+ DeleteRexxHost(rexxhost);
+
+void Host_wait(rexxhost,timeout)
+ APTR rexxhost
+ int timeout
+ CODE:
+ WaitRexxHost(rexxhost,timeout);
+
+uint32 Host_signal(rexxhost)
+ APTR rexxhost
+ CODE:
+ RETVAL = GetSignalRexxHost(rexxhost);
+ OUTPUT:
+ RETVAL
+
+APTR Host_getmsg(rexxhost)
+ APTR rexxhost
+ CODE:
+ RETVAL = GetMsgRexxHost(rexxhost);
+ OUTPUT:
+ RETVAL
+
+void Msg_reply(rexxmsg,rc,rc2,result)
+ APTR rexxmsg
+ int rc
+ int rc2
+ STRPTR result
+ CODE:
+ ReplyARexxMsg(rexxmsg,rc,rc2,result);
+
+void Msg_delete(rexxmsg)
+ APTR rexxmsg
+ CODE:
+ DeleteARexxMsg(rexxmsg);
+
+STRPTR Msg_argstr(rexxmsg)
+ APTR rexxmsg
+ CODE:
+ RETVAL = GetArgsARexxMsg(rexxmsg);
+ OUTPUT:
+ RETVAL
+
+STRPTR Msg_getvar(rexxmsg,varname)
+ APTR rexxmsg
+ STRPTR varname
+ PPCODE:
+ RETVAL = GetVarARexxMsg(rexxmsg,varname);
+ sv_setpv(TARG, RETVAL); XSprePUSH; PUSHTARG;
+ if (RETVAL) IExec->FreeVec(RETVAL);
+
+void Msg_setvar(rexxmsg,varname,value)
+ APTR rexxmsg
+ STRPTR varname
+ STRPTR value
+ CODE:
+ SetVarARexxMsg(rexxmsg,varname,value);
+
+STRPTR _DoRexx(port,command,rc,rc2)
+ STRPTR port
+ STRPTR command
+ int32 &rc
+ int32 &rc2
+ PPCODE:
+ RETVAL = DoRexx(port,command,&rc,&rc2);
+ sv_setiv(ST(2), (IV)rc);
+ SvSETMAGIC(ST(2));
+ sv_setiv(ST(3), (IV)rc2);
+ SvSETMAGIC(ST(3));
+ sv_setpv(TARG, RETVAL); XSprePUSH; PUSHTARG;
+ IExec->FreeVec(RETVAL);
+
--- /dev/null
+use 5.008005;
+use ExtUtils::MakeMaker;
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
+# the contents of the Makefile that is written.
+WriteMakefile(
+ NAME => 'Amiga::ARexx',
+ VERSION_FROM => 'ARexx.pm', # finds $VERSION
+ PREREQ_PM => {}, # e.g., Module::Name => 1.1
+ ($] >= 5.005 ? ## Add these new keywords supported since 5.005
+ (ABSTRACT_FROM => 'ARexx.pm', # retrieve abstract from module
+ AUTHOR => 'A R Broad <andy@broad.ology.org.uk>') : ()),
+ LIBS => ['-lauto -lraauto'], # e.g., '-lm'
+ DEFINE => '', # e.g., '-DHAVE_SOMETHING'
+ INC => '-I.', # e.g., '-I. -I/usr/include/other'
+ # Un-comment this if you add C files to link with later:
+ # OBJECT => '$(O_FILES)', # link all the C files too
+);
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+use Amiga::ARexx qw(DoRexx);
+
+my ($result,$rc,$rc2) = DoRexx("WORKBENCH","HELP");
+
+print $result , "\n" , $rc, "\n", $rc2 , "\n";
+
+($result,$rc,$rc2) = DoRexx("WORKBENCH","NOHELP");
+
+print $result , "\n" , $rc, "\n", $rc2 , "\n";
--- /dev/null
+#!perl
+
+# Simple ARExx Host
+
+use strict;
+use Amiga::ARexx;
+use feature "switch";
+
+my $host = Amiga::ARexx->new('HostName' => "TESTSCRIPT");
+
+my $alive = 1;
+
+while ($alive)
+{
+ $host->wait();
+ my $msg = $host->getmsg();
+ while($msg)
+ {
+ my $rc = 0;
+ my $rc2 = 0;
+ my $result = "";
+
+ print $msg->message . "\n";
+ given($msg->message)
+ {
+ when ("QUIT")
+ {
+ $alive = 0;
+ $result = "quitting!";
+ }
+ when ("SHOUT")
+ {
+ $result = "HEEELLLLOOOO!";
+ }
+ default {
+ $rc = 10;
+ $rc2 = 22;
+ }
+ }
+ $msg->reply($rc,$rc2,$result);
+
+ $msg = $host->getmsg();
+ }
+
+}
+
--- /dev/null
+/* defines types for tags */
+#ifndef _TAGTYPES_H
+#define _TAGTYPES_H
+
+#define TT_APTR 1
+#define TT_WORD 2
+#define TT_UWORD 3
+#define TT_LONG 4
+#define TT_ULONG 5
+#define TT_STRPTR 6
+#define TT_UBYTE 7
+
+typedef union TagReturn
+{
+ WORD tr_word;
+ UWORD tr_uword;
+ LONG tr_long;
+ ULONG tr_ulong;
+ STRPTR tr_strptr;
+ APTR tr_aptr;
+ UBYTE * tr_ubyte;
+}
+TAGRET;
+
+#endif
--- /dev/null
+APTR T_PTR
+intArray * T_ARRAY
+UWORD T_UV
+ULONG T_UV
+WORD T_IV
+LONG T_IV
+BOOL T_IV
+TagList * T_TAGLIST
+TAGRET T_TAGRET
+STRPTR T_PV
+int32 T_IV
+uint32 T_UV
+
+#############################################################################
+INPUT
+T_TAGLIST
+ U32 ix_$var = $argoff;
+ U32 _tag_type;
+ /* allocate taglist struct, +2 as tags lists end in a TAG_DONE by tradition */
+ /* if by some chance someone adds something after the TAG_DONE it will just*/
+ /* result in harmless empty space */
+ $var = $ntype((items -= $argoff) +2);
+ while(items > 0)
+ {
+ int __index = (ix_$var - $argoff)/3;
+ $var\[__index\].ti_Tag = (ULONG)SvUV(ST(ix_$var));
+ ix_$var++;
+ items--;
+ /* the last is a tag_done and usualy has no followers so check for > 1 */
+ if(items > 1 && ($var\[__index\].ti_Tag != TAG_DONE))
+ {
+ _tag_type = (ULONG)SvUV(ST(ix_$var));
+ ix_$var++;
+ switch(_tag_type)
+ {
+ case TT_APTR:
+ $var\[__index\].ti_Data = (ULONG)INT2PTR(APTR,SvIV(ST(ix_$var)));
+ break;
+ case TT_WORD:
+ $var\[__index\].ti_Data = (WORD)SvIV(ST(ix_$var));
+ break;
+ case TT_LONG:
+ $var\[__index\].ti_Data = (LONG)SvIV(ST(ix_$var));
+ break;
+ case TT_UWORD:
+ $var\[__index\].ti_Data = (UWORD)SvUV(ST(ix_$var));
+ break;
+ case TT_ULONG:
+ $var\[__index\].ti_Data = (ULONG)SvUV(ST(ix_$var));
+ break;
+ case TT_STRPTR:
+ case TT_UBYTE:
+ $var\[__index\].ti_Data = (ULONG)(STRPTR)SvPV_nolen(ST(ix_$var));
+ break;
+ default:
+ Perl_croak(aTHX_ \"Unknown TAGTYPE \%d\",_tag_type);
+ }
+ ix_$var++;
+ items -=2;
+ }
+ }
+
+T_TAGRET
+ /* Allocate variable type according to preceding var tagtype */
+ switch(tagtype)
+ {
+ case TT_APTR:
+ $var.tr_aptr = INT2PTR(APTR,SvIV($arg));
+ break;
+ case TT_WORD:
+ $var.tr_word = (WORD)SvIV($arg);
+ break;
+ case TT_LONG:
+ $var.tr_long = (LONG)SvIV($arg);
+ case TT_UWORD:
+ $var.tr_uword = (UWORD)SvUV($arg);
+ break;
+ case TT_ULONG:
+ $var.tr_ulong = (ULONG)SvUV($arg);
+ break;
+ case TT_STRPTR:
+ case TT_UBYTE:
+ $var.tr_strptr = (STRPTR)SvPV_nolen($arg);
+ break;
+ default:
+ Perl_croak(aTHX_ \"Unknown TAGTYPE \%d\",tagtype);
+ }
+
+####################################################################################
+OUTPUT
+T_TAGRET
+ /* Allocate variable type according to preceding var tagtype */
+ switch(tagtype)
+ {
+ case TT_APTR:
+ sv_setiv($arg, PTR2IV($var.tr_aptr));
+ break;
+ case TT_WORD:
+ sv_setiv($arg, (IV)$var.tr_word);
+ break;
+ case TT_LONG:
+ sv_setiv($arg, (IV)$var.tr_long);
+ break;
+ case TT_UWORD:
+ sv_setuv($arg, (UV)$var.tr_uword);
+ break;
+ case TT_ULONG:
+ sv_setuv($arg, (UV)$var.tr_ulong);
+ break;
+ case TT_STRPTR:
+ case TT_UBYTE:
+ sv_setpv((SV*)$arg, $var.tr_strptr);
+ break;
+ default:
+ Perl_croak(aTHX_ \"Unknown TAGTYPE \%d\",tagtype);
+ }
+
+
--- /dev/null
+package Amiga::Exec;
+
+use 5.016000;
+use strict;
+use warnings;
+use Carp;
+
+require Exporter;
+#use AutoLoader;
+
+our @ISA = qw(Exporter);
+
+# Items to export into callers namespace by default. Note: do not export
+# names by default without a very good reason. Use EXPORT_OK instead.
+# Do not simply export all your public functions/methods/constants.
+
+# This allows declaration use Amiga::Exec ':all';
+# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
+# will save memory.
+our %EXPORT_TAGS = ( 'all' => [ qw(
+Wait
+) ] );
+
+our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
+
+our @EXPORT = qw(
+);
+
+our $VERSION = '0.01';
+
+require XSLoader;
+XSLoader::load('Amiga::Exec', $VERSION);
+
+
+sub Wait
+{
+ my %params = @_;
+ my $signalmask = 0;
+ my $timeout = 0;
+
+ if(exists $params{'SignalMask'})
+ {
+ $signalmask = $params{'SignalMask'};
+ }
+ if(exists $params{'TimeOut'})
+ {
+ $timeout = $params{'TimeOut'};
+ }
+
+ my $result = Amiga::Exec::_Wait($signalmask,$timeout);
+ return $result;
+}
+
+
+
+# Preloaded methods go here.
+
+# Autoload methods go after =cut, and are processed by the autosplit program.
+
+1;
+__END__
+# Below is stub documentation for your module. You'd better edit it!
+
+=head1 NAME
+
+Amiga::Exec - Perl extension for low level amiga support
+
+=head1 ABSTRACT
+
+This a perl class / module to enables you to use various low level Amiga features such as waiting on an Exec signal
+
+=head1 SYNOPSIS
+
+ # Wait for signla
+
+ use Amiga::Exec;
+ my $result = Amiga::ARexx->Wait('SignalMask' => $signalmask, 'TimeOut' => $timeoutinusecs); );
+
+
+=head1 DESCRIPTION
+
+The interface to Exec in entirely encapsulated within the perl class, there
+is no need to access the low level methods directly and they are not exported by default.
+
+=head1 Amiga::ARexx METHODS
+
+=head2 Wait
+
+ $signals = Amiga::Exec->Wait('SignalMask' => $signalmask, 'TimeOut' => $timeoutinusecs );
+
+Wait on a signal set with optional timeout. The result ($signals) should be checked to
+determine which signal was raised. It will be 0 for timeout.
+
+=head3 Signal
+
+The signal Exec signal mask
+
+=head3 TimeOut
+
+optional time out in microseconds.
+
+=head2 EXPORT
+
+None by default.
+
+=head2 Exportable constants
+
+None
+
+=head1 AUTHOR
+
+Andy Broad <andy@broad.ology.org.uk>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2013 by Andy Broad.
+
+
+=cut
+
+
+
--- /dev/null
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#include "ppport.h"
+
+#undef __USE_INLINE__
+#include <exec/types.h>
+#include <utility/tagitem.h>
+#include <dos/dos.h>
+#include <proto/exec.h>
+#include <proto/intuition.h>
+#include <proto/utility.h>
+
+
+
+struct TimeRequest *
+OpenTimer(void)
+{
+ struct MsgPort *port = IExec->AllocSysObjectTags(ASOT_PORT, TAG_END);
+ if (port == NULL)
+ {
+ return NULL;
+ }
+
+ struct TimeRequest *req = IExec->AllocSysObjectTags(ASOT_IOREQUEST,
+ ASOIOR_Size, sizeof(struct TimeRequest),
+ ASOIOR_ReplyPort, port,
+ TAG_END);
+
+ if (req == NULL)
+ {
+ IExec->FreeSysObject(ASOT_PORT, port);
+ return NULL;
+ }
+
+ int8 deverr = IExec->OpenDevice("timer.device", UNIT_MICROHZ,
+ &req->Request, 0);
+
+ if (deverr != IOERR_SUCCESS)
+ {
+ IExec->FreeSysObject(ASOT_IOREQUEST, req);
+ IExec->FreeSysObject(ASOT_PORT, port);
+ return NULL;
+ }
+
+ return req;
+}
+
+
+void
+CloseTimer(struct TimeRequest *req)
+{
+ if (req != NULL)
+ {
+ struct MsgPort *port = req->Request.io_Message.mn_ReplyPort;
+
+ IExec->CloseDevice(&req->Request);
+ IExec->FreeSysObject(ASOT_IOREQUEST, req);
+ IExec->FreeSysObject(ASOT_PORT, port);
+ }
+}
+
+
+
+uint32 WaitTimeout(uint32 signalmask , int timeout)
+{
+
+ struct TimeRequest *req = NULL;
+ uint32 timermask = 0;
+
+ if (timeout > 0)
+ {
+ req = OpenTimer();
+
+ if (req != NULL)
+ {
+ timermask = 1L << req->Request.io_Message.mn_ReplyPort->mp_SigBit;
+
+ req->Request.io_Command = TR_ADDREQUEST;
+ req->Time.Seconds = 0;
+ req->Time.Microseconds = timeout;
+
+ IExec->SendIO(&req->Request);
+ }
+ }
+
+ uint32 waitmask = timermask | signalmask | SIGBREAKF_CTRL_C;
+
+ uint32 sigmask = IExec->Wait(waitmask);
+
+ if (req != NULL)
+ {
+ IExec->AbortIO(&req->Request);
+ IExec->WaitIO(&req->Request);
+ CloseTimer(req);
+ }
+
+ /* remove the timer mask bit */
+
+ return sigmask & (~timermask );
+}
+
+
+
+MODULE = Amiga::Exec PACKAGE = Amiga::Exec
+
+PROTOTYPES: DISABLE
+
+
+uint32 _Wait(signalmask,timeout)
+ uint32 signalmask;
+ uint32 timeout;
+ CODE:
+ RETVAL = WaitTimeout(signalmask,timeout);
+ OUTPUT:
+ RETVAL
+
--- /dev/null
+use 5.008005;
+use ExtUtils::MakeMaker;
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
+# the contents of the Makefile that is written.
+WriteMakefile(
+ NAME => 'Amiga::Exec',
+ VERSION_FROM => 'Exec.pm', # finds $VERSION
+ PREREQ_PM => {}, # e.g., Module::Name => 1.1
+ ($] >= 5.005 ? ## Add these new keywords supported since 5.005
+ (ABSTRACT_FROM => 'Exec.pm', # retrieve abstract from module
+ AUTHOR => 'A R Broad <andy@broad.ology.org.uk>') : ()),
+ LIBS => ['-lauto'], # e.g., '-lm'
+ DEFINE => '', # e.g., '-DHAVE_SOMETHING'
+ INC => '-I.', # e.g., '-I. -I/usr/include/other'
+ # Un-comment this if you add C files to link with later:
+ # OBJECT => '$(O_FILES)', # link all the C files too
+);
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+use Amiga::ARexx qw(DoRexx);
+
+my ($result,$rc,$rc2) = DoRexx("WORKBENCH","HELP");
+
+print $result , "\n" , $rc, "\n", $rc2 , "\n";
+
+($result,$rc,$rc2) = DoRexx("WORKBENCH","NOHELP");
+
+print $result , "\n" , $rc, "\n", $rc2 , "\n";
--- /dev/null
+#!perl
+
+# Simple ARExx Host
+
+use strict;
+use Amiga::ARexx;
+use feature "switch";
+
+my $host = Amiga::ARexx->new('HostName' => "TESTSCRIPT");
+
+my $alive = 1;
+
+while ($alive)
+{
+ $host->wait();
+ my $msg = $host->getmsg();
+ while($msg)
+ {
+ my $rc = 0;
+ my $rc2 = 0;
+ my $result = "";
+
+ print $msg->message . "\n";
+ given($msg->message)
+ {
+ when ("QUIT")
+ {
+ $alive = 0;
+ $result = "quitting!";
+ }
+ when ("SHOUT")
+ {
+ $result = "HEEELLLLOOOO!";
+ }
+ default {
+ $rc = 10;
+ $rc2 = 22;
+ }
+ }
+ $msg->reply($rc,$rc2,$result);
+
+ $msg = $host->getmsg();
+ }
+
+}
+
--- /dev/null
+/* defines types for tags */
+#ifndef _TAGTYPES_H
+#define _TAGTYPES_H
+
+#define TT_APTR 1
+#define TT_WORD 2
+#define TT_UWORD 3
+#define TT_LONG 4
+#define TT_ULONG 5
+#define TT_STRPTR 6
+#define TT_UBYTE 7
+
+typedef union TagReturn
+{
+ WORD tr_word;
+ UWORD tr_uword;
+ LONG tr_long;
+ ULONG tr_ulong;
+ STRPTR tr_strptr;
+ APTR tr_aptr;
+ UBYTE * tr_ubyte;
+}
+TAGRET;
+
+#endif
--- /dev/null
+APTR T_PTR
+intArray * T_ARRAY
+UWORD T_UV
+ULONG T_UV
+WORD T_IV
+LONG T_IV
+BOOL T_IV
+TagList * T_TAGLIST
+TAGRET T_TAGRET
+STRPTR T_PV
+int32 T_IV
+uint32 T_UV
+
+#############################################################################
+INPUT
+T_TAGLIST
+ U32 ix_$var = $argoff;
+ U32 _tag_type;
+ /* allocate taglist struct, +2 as tags lists end in a TAG_DONE by tradition */
+ /* if by some chance someone adds something after the TAG_DONE it will just*/
+ /* result in harmless empty space */
+ $var = $ntype((items -= $argoff) +2);
+ while(items > 0)
+ {
+ int __index = (ix_$var - $argoff)/3;
+ $var\[__index\].ti_Tag = (ULONG)SvUV(ST(ix_$var));
+ ix_$var++;
+ items--;
+ /* the last is a tag_done and usualy has no followers so check for > 1 */
+ if(items > 1 && ($var\[__index\].ti_Tag != TAG_DONE))
+ {
+ _tag_type = (ULONG)SvUV(ST(ix_$var));
+ ix_$var++;
+ switch(_tag_type)
+ {
+ case TT_APTR:
+ $var\[__index\].ti_Data = (ULONG)INT2PTR(APTR,SvIV(ST(ix_$var)));
+ break;
+ case TT_WORD:
+ $var\[__index\].ti_Data = (WORD)SvIV(ST(ix_$var));
+ break;
+ case TT_LONG:
+ $var\[__index\].ti_Data = (LONG)SvIV(ST(ix_$var));
+ break;
+ case TT_UWORD:
+ $var\[__index\].ti_Data = (UWORD)SvUV(ST(ix_$var));
+ break;
+ case TT_ULONG:
+ $var\[__index\].ti_Data = (ULONG)SvUV(ST(ix_$var));
+ break;
+ case TT_STRPTR:
+ case TT_UBYTE:
+ $var\[__index\].ti_Data = (ULONG)(STRPTR)SvPV_nolen(ST(ix_$var));
+ break;
+ default:
+ Perl_croak(aTHX_ \"Unknown TAGTYPE \%d\",_tag_type);
+ }
+ ix_$var++;
+ items -=2;
+ }
+ }
+
+T_TAGRET
+ /* Allocate variable type according to preceding var tagtype */
+ switch(tagtype)
+ {
+ case TT_APTR:
+ $var.tr_aptr = INT2PTR(APTR,SvIV($arg));
+ break;
+ case TT_WORD:
+ $var.tr_word = (WORD)SvIV($arg);
+ break;
+ case TT_LONG:
+ $var.tr_long = (LONG)SvIV($arg);
+ case TT_UWORD:
+ $var.tr_uword = (UWORD)SvUV($arg);
+ break;
+ case TT_ULONG:
+ $var.tr_ulong = (ULONG)SvUV($arg);
+ break;
+ case TT_STRPTR:
+ case TT_UBYTE:
+ $var.tr_strptr = (STRPTR)SvPV_nolen($arg);
+ break;
+ default:
+ Perl_croak(aTHX_ \"Unknown TAGTYPE \%d\",tagtype);
+ }
+
+####################################################################################
+OUTPUT
+T_TAGRET
+ /* Allocate variable type according to preceding var tagtype */
+ switch(tagtype)
+ {
+ case TT_APTR:
+ sv_setiv($arg, PTR2IV($var.tr_aptr));
+ break;
+ case TT_WORD:
+ sv_setiv($arg, (IV)$var.tr_word);
+ break;
+ case TT_LONG:
+ sv_setiv($arg, (IV)$var.tr_long);
+ break;
+ case TT_UWORD:
+ sv_setuv($arg, (UV)$var.tr_uword);
+ break;
+ case TT_ULONG:
+ sv_setuv($arg, (UV)$var.tr_ulong);
+ break;
+ case TT_STRPTR:
+ case TT_UBYTE:
+ sv_setpv((SV*)$arg, $var.tr_strptr);
+ break;
+ default:
+ Perl_croak(aTHX_ \"Unknown TAGTYPE \%d\",tagtype);
+ }
+
+
https://perl5.git.perl.org / perl5.git / commitdiff