/*
** ARexx-Script for MicroDot
**
** $VER: ThreadIt 1.0 (19.02.2000) Copyright � 2000 by Kai Schindelka
*/
/*
** $VER: Libraries 1.0 (28.8.98)
**
** Global vars: i, j, li.
**
** Requires : rexxtricks-, reqtools-, rexxreqtools- and rexxsupport.library
**
** Purpose : Includes libraries, exits on error
*/
li.1 = 'rexxtricks.library'
li.2 = 'rexxreqtools.library'
li.3 = 'rexxsupport.library'
j = 38
DO i = 1 TO 3
IF ~ SHOW('Libraries', li.i) THEN
IF ~ ADDLIB(li.i, 0, -30, j) THEN CALL Quit 10
j = 0
END
/*
** $VER: Interrupts 1.1 (29.11.97)
**
** Purpose : Initialisation of error interrupts
**
** Switches on all error interrupts except 'NOVALUE'. Note that the
** 'ARexx.guide' states 'BREAK_C', 'FAILURE', 'HALT' and 'SYNTAX'
** were ON by default, but this is obviously not true.
*/
SIGNAL ON BREAK_C
SIGNAL ON BREAK_D
SIGNAL ON BREAK_E
SIGNAL ON BREAK_F
SIGNAL ON ERROR
SIGNAL ON FAILURE
SIGNAL ON HALT
SIGNAL ON IOERR
SIGNAL ON SYNTAX
/*
** $VER: GetPort 1.0 (28.8.98)
**
** Global vars: po
**
** Purpose : Stores the port name of the calling process
*/
po = ADDRESS()
/*
** $VER: Results 1.0 (28.8.98)
**
** Purpose : Triggers storage of external result values
*/
OPTIONS RESULTS
/*
** $VER: SetPubScreen 1.0 (28.8.98)
**
** Global vars: ds, ps
**
** Requires : rexxtricks.library, MicroDot
**
** Purpose : Sets the current MicroDot public screen as default, stores the name of
the old default screen
*/
GETMDPUBSCREENNAME
ps = result
ds = SETDEFAULTPUBSCREEN(ps)
/*
** $VER: GetProgName 1.0 (28.8.98)
**
** Global vars: pr.
**
** Custom Fncs: GetVer()
**
** Purpose : Retrieves the program name, version and freeze date
*/
PARSE VALUE GetVer(4) WITH pr.pn pr.ve pr.dt .
/*
** $VER: InitVars 1.1 (19.02.2000)
**
** Global vars: cr, lf, pr.
**
** Purpose : Initialises LineFeed, CarriageReturn and program specific variables
(most of them for requesters)
*/
lf = '0A'x
cr = '0D'x
pr.au = '[EMAIL PROTECTED] (Kai Schindelka)'
pr.ri = 'Information'
pr.rm = 'Meldung'
pr.em = 'Fehlermeldung'
pr.aw = 'Aktionswahl'
pr.gp = '_Ok'
pr.gn = '_Abbruch'
pr.ti = pr.pn' V'pr.ve': '
pr.er = pr.ti || pr.em
pr.ir = pr.pn' 'pr.ve' 'pr.dt || lf,
'Copyright � 1996-98 by Kai Schindelka'lf,
'All rights reserved'lf || lf,
'-> MAILWARE <-'lf || lf,
'Ein ARexx-Skript f�r MicroDot.'lf,
'Fehlermeldungen, Fragen, Anregungen, Kritik'lf,
'�nderungsw�nsche und Kommentare bitte an:'lf,
'�'pr.au'�'lf || lf,
'Updates und fehlende Dateien erh�ltlich bei:'lf || lf,
'Silver Server'lf || COPIES('*', 10) || lf,
'(Nachricht an obige Adresse,'lf,
'"Help" im Body, Betreff egal)'lf
pr.ta = 'rt_lockwindow=true',
'rt_pubscrname='ps,
' rt_reqpos=reqpos_centerscr',
'rt_screentofront=true',
'rt_waitpointer=true'
pr.rt = pr.ta' rtez_flags=ezreqf_centertext'
pr.st = pr.ta' rtgs_backfill=true',
'rtgs_flags=gsreqf_centertext'
/*
** $VER: Tempfile 1.0 (28.8.98)
**
** Global vars: tm
**
** Purpose : Define path and name of the program tempfile
*/
tm = 'T:'pr.pn'.tmp'
/*
** $VER: MDVersion 1.0 (28.8.98)
**
** Global vars: de
**
** Requires : MicroDot
**
** Purpose : Checks MicroDot version and sets boolean trigger value for MD commands
'CHOOSE' resp. 'SELECT'
*/
MDVERSION
de = COMPRESS(LEFT(result, 4), 'b. ') > 19
/*
** $VER: GetTotalMessages 1.0 (28.8.98)
**
** Global vars: tn
**
** Requires : MicroDot
**
** Purpose : Retrieves the total number of messages of the current board in MicroDot
*/
GETCURRENTBOARD
tn = WORD(result, 2)
/*
** $VER: Cursor 1.0 (28.8.98)
**
** Global vars: cp
**
** Requires : MicroDot
**
** Purpose : Stores the current cursor position in a MicroDot board
*/
GETPOS
cp = result
/*
** $VER: CheckMessage 1.0 (28.8.98)
**
** Global vars: de, po
**
** Requires : MicroDot
**
** Purpose : Checks if the current message is selected in a MicroDot board by using
the appropriate MD command
*/
IF de THEN CHOOSE TEST
ELSE INTERPRET 'SHELL 'po' SELECT TEST'
/* If the origin is selected, deselect it to avoid a reference loop */
IF result THEN CALL Deselect
/* Retrieve the ID of the current message */
id = GetHeader(MID)
/* Reset counter for selected messages */
cn = 0
/* Check every message */
DO i = 0 TO tn - 1
/* Set cursor to current message position */
SETPOS i
/*
** $VER: CheckMessage 1.0 (28.8.98)
**
** Global vars: de, po
**
** Requires : MicroDot
**
** Purpose : Checks if the current message is selected in a MicroDot board by using
the appropriate MD command
*/
IF de THEN CHOOSE TEST
ELSE INTERPRET 'SHELL 'po' SELECT TEST'
/* If the message is selected, raise the counter */
IF result THEN cn = cn + 1
END
/* If selected messages were found, work on them */
IF cn > 0 THEN DO
/* Make Fakekey resident */
CALL Fakekey
/* Open message editor requester */
SHELL COMMAND 'Fakekey 0 lshift e'
/* All selected messages... */
DO cn
/* ...get the Message-ID of the origin as a reference */
CALL AddHeader 'BEZ:'id
END
END
/*
** $VER: Xit 1.0 (20.10.97)
**
** Subroutines: Quit
**
** Purpose : Calls 'Quit:' with return value 0 (in other words: ends program)
*/
CALL Quit 0
/*
** $VER: GetHeader() 1.0 (27.8.98)
**
** Template : rv = GetHeader(<header name>)
**
** rv is a : string
**
** Requires : MicroDot
**
** Purpose : Retrieves a non-compulsory header of the current message in a MicroDot
board
*/
GetHeader: PROCEDURE
/* Parse the header name */
ARG du
/* Switch 'ERROR'- and 'FAILURE'-interrupts temporarily off */
SIGNAL OFF ERROR
SIGNAL OFF FAILURE
/* Attempt to retrieve the header */
GETCURRENTMAILHEADER du
/* Switch 'ERROR'- and 'FAILURE'-interrupts on again */
SIGNAL ON ERROR
SIGNAL ON FAILURE
/* If the header doesn't exist, reset the result string */
IF result = 'RESULT' THEN result = ''
/* Return the result to the calling routine */
RETURN result
/*
** $VER: AddHeader 1.0 (19.02.2000)
**
** Template : CALL AddHeader(<header string>)
**
** Global vars: de, ps
**
** Subroutines: FakeKey
**
** Requires : rexxtricks.library, custom command 'FakeKey', MicroDot
**
** Purpose : Adds a header to a message in a MicroDot board
*/
AddHeader: PROCEDURE EXPOSE ps
/* Parse the file name */
PARSE ARG he
/* Initialise command variable */
fk = 'FakeKey '
/* Move Microdot's public screen to the front */
CALL PUBSCREENTOFRONT(ps)
/* Send the following commands to ADOS */
SHELL COMMAND
/* Wait a second to avoid timing problems, then switch to header edit requester
*/
fk'1 h'
/* Switch to 'New header' input requester */
fk'0 n'
/* Type in the new header, escape hyphens,... */
DO j = 1 TO LENGTH(he)
dm = SUBSTR(he, j, 1)
IF dm = '-' THEN dm = '--'
fk'0 'dm
END
/* ...and complete the input */
fk'0 return'
/* Leave the header edit requester */
fk'0 o'
/* And send the message */
fk'0 v'
/* Switch back to the calling process */
SHELL
/* Return to the calling routine */
RETURN
/*
** $VER: Deselect 1.0 (28.8.98)
**
** Template : CALL Deselect
**
** Global vars: de, po
**
** Requires : MicroDot
**
** Purpose : Deselects the current message in a MicroDot board
*/
Deselect:
/* Deselect the current message, use appropriate MicroDot command */
IF de THEN CHOOSE OFF
ELSE INTERPRET 'SHELL 'po' SELECT OFF'
/* Return to the calling routine */
RETURN
/*
** $VER: FakeKey 1.1 (14.11.98)
**
** Template : CALL FakeKey
**
** Requires : rexxsupport.library, ADOS-command 'Resident'
**
** Purpose : Makes the custom command 'FakeKey' resident
*/
FakeKey: PROCEDURE
/* Initialise file name */
du = 'RAM:T/FakeKey'
/* Use file name as Tempfile for Resident's list output */
SHELL COMMAND 'Resident >'du
/* Open file for reading */
CALL OPEN sr, du, 'Read'
/* Read data */
dm = READCH(sr, 4096)
/* Close file */
CALL CLOSE sr
/* If FakeKey is already resident, delete Tempfile and return */
IF POS('FakeKey', dm) > 0 THEN DO
/* Delete file */
CALL DELETE du
/* Return to the calling routine */
RETURN
END
/* Initialise data stem variable */
fk.1 = '000003F300000000000000010000000000000000000000B2000003E9000000B2'x
fk.2 = '4E55FFF42B7C00000000FFF47E007C007A007800287C00000000267C00000000'x
fk.3 = '247C000000002C78000443FA01B470254EAEFDD82E006600000E41FA02306100'x
fk.4 = '01766000016843FA01A470254EAEFDD82C006600000E41FA02326100015A6000'x
fk.5 = '014C2C4741FA019A220841EDFFF8240876004EAEFCE22A0067000132206DFFF8'x
fk.6 = '2210C2FC00324EAEFF3A2C7800044EAEFD66280067000116204470304EAEFD72'x
fk.7 = '28404A806700010641FA016F7000224C72004EAEFE444A80660000F27016223C'x
fk.8 = '000100004EAEFF3A26404A80670000DE700C223C000100004EAEFF3A24404A80'x
fk.9 = '670000CA2C46206DFFFC224A4EAEFF7C4A806700000E41FA01B0610000BA6000'x
fk.10 = '00AC176A00010004376A00020006376A00060008224C234B0028237C00000016'x
fk.11 = '0024337C000B001C2C7800044EAEFE384A8066000078224C006B008000064EAE'x
fk.12 = 'FE382205670000082C474EAEFCA62C780004224B20096700000870164EAEFF2E'x
fk.13 = '224A200967000008700C4EAEFF2E224C20096700000C4EAEFE3E204C4EAEFD6C'x
fk.14 = '20442008670000064EAEFD6022462009670000064EAEFE622247200967000006'x
fk.15 = '4EAEFE62202DFFF44E5D4E752B7C0000000AFFF4608C48E700822C78000443FA'x
fk.16 = '002070004EAEFDD82C404EAEFFC42200241F263C0000001E4EAEFFD02C5F4E75'x
fk.17 = '646F732E6C69627261727900636F6D6D6F6469746965732E6C69627261727900'x
fk.18 = '74696D656F75742F4E2F412C6B657970726573732F462F4100696E7075742E64'x
fk.19 = '657669636500245645523A2046616B656B657920312E302028322E322E393329'x
fk.20 = '2020200A427920446F75676C6173204E656C736F6E2E20467265656C79206469'x
fk.21 = '7374726962757461626C652E596F75206E65656420416D696761444F5320322E'x
fk.22 = '7821202020202020200A4E6F20636F6D6D6F6469746965732E6C696272617279'x
fk.23 = '212020202020200A496E76616C696420696E7075742120202020202020202020'x
fk.24 = '20202020200A0000000003F2'x
/* Append strings */
dm = ''
DO i = 1 TO 24
dm = dm || fk.i
END
/* Open file for writing */
CALL OPEN sr, du, 'Write'
/* Write data */
CALL WRITECH sr, dm
/* Close file */
CALL CLOSE sr
/* Make command resident */
SHELL COMMAND 'Resident 'du' PURE'
/* Delete file */
CALL DELETE du
/* Return to the calling routine */
RETURN
/*
** $VER: GetChoice() 1.0 (27.8.98)
**
** Template : rv = GetChoice(<body text>, <gadget text>, [<additional requester
title>])
**
** rv is a : number
**
** Global vars: pr.
**
** Requires : reqtools- and rexxreqtools.library
**
** Purpose : Invokes a message requester and returns its result to the calling
routine
*/
GetChoice: PROCEDURE EXPOSE pr.
/* Parse body text, gadget text and addition to requester titel */
PARSE ARG du, ga, te
/* Invoke the requester */
CALL rtezrequest du, ga, pr.ti || te, pr.rt
/* Return the result to the calling routine */
RETURN rtresult
/*
** $VER: GetVer() 1.1 (30.11.97)
**
** Template : rv = GetVer(<number>)
**
** rv is a : string
**
** Main code : GetProgName.mai
**
** Purpose : Attempts to retrieve the version string from the
** first <number> source lines of the current program
**
** Invocation : i. e. 'PARSE VALUE GetVer(<number>) WITH name version date .'
*/
GetVer: PROCEDURE
/* Parse the number of lines to search */
ARG j
/* Do 'j' number of loops */
DO i = 1 TO j
/* Read a source line (start at line 1) */
du = SOURCELINE(i)
/* Check if the version keyword is somewhere on this line */
k = FIND(du, '$VER:')
/* Keyword found */
IF k > 0 THEN DO
/* Retrieve next three words: program name, version and freeze date */
du = SUBWORD(du, k + 1, 3)
/* Leave the loop */
LEAVE
END
END
/* Return the version string to the calling routine */
RETURN du
/*
** $VER: Err 1.1 (27.8.98)
**
** Template : CALL Err <body text>, <boolean exit trigger value>
**
** Global vars: pr.
**
** Subroutines: Quit
**
** Requires : rexxtricks-, reqtools- and rexxreqtools.library
**
** Purpose : Posts an error message and exits if trigger value = true
*/
Err:
/* Parse body text and boolean exit trigger value */
PARSE ARG du, i
/* Call DisplayBeep() */
CALL BEEP
/* Show error requester */
CALL rtezrequest du, pr.gn, pr.er, pr.rt
/* If exit = 'true' then end program */
IF i THEN CALL Quit 10
/* ...else return to the calling routine */
ELSE RETURN
/*
** $VER: Sntx 1.4 (28.8.98)
**
** Global vars: lf, pr.
**
** Subroutines: Err
**
** Purpose : Global error interrupt trapping
*/
ERROR:
FAILURE:
IOERR:
SYNTAX:
/* Switch off the interrupts to prevent recursion */
SIGNAL OFF ERROR
SIGNAL OFF FAILURE
SIGNAL OFF SYNTAX
/* Post error message and exit */
CALL Err 'Es ist ein FEHLER Nr. 'rc' in Zeile 'sigl' aufgetreten!'lf || lf,
'Die Zeile, die den Abbruch ausgel�st hat, lautet'lf,
'"'SOURCELINE(sigl)'".'lf,
'Der ARexx-Interpreter gibt als Fehlerursache'lf,
'"'ERRORTEXT(rc)'" an.'lf || lf,
'Bei programminternen Fehlern bitte unbedingt'lf,
'eine Bugmeldung mit den obigen Angaben an den'lf,
'Autoren versenden! Die e-mail-Adresse lautet:'lf'�'pr.au'�.', 1
/* We should never reach this point, but just to close the subroutine correctly */
EXIT 10
/*
** $VER: BrkHlt 1.6 (28.8.98)
**
** Global vars: pr.
**
** Subroutines: 'Err'
**
** Purpose : {BREAK} and {HALT} error interrupt trapping
*/
BREAK_C:
BREAK_D:
BREAK_E:
BREAK_F:
HALT:
/* Switch off the interrupts to prevent recursion */
SIGNAL OFF BREAK_C
SIGNAL OFF BREAK_D
SIGNAL OFF BREAK_E
SIGNAL OFF BREAK_F
SIGNAL OFF HALT
/* Post error message and exit */
CALL Err '"Break" oder globales "Halt"-Signal empfangen!' || '0A'x,
pr.pn' V'pr.ve' wird beendet.', 1
/* We should never reach this point, but just to close the subroutine correctly */
EXIT 10
/*
** $VER: Quit 1.2 (28.8.98)
**
** Template : CALL Quit <return value>
**
** Global vars: cp, da, ds, pd, tm
**
** Requires : rexxsupport- and rexxtricks.library, 'Assign', MicroDot
**
** Purpose : Cleans up and exits with return value
*/
Quit:
/* Parse return value */
PARSE ARG du
/* Attempt to restore the original cursor position in MicroDot */
IF cp ~ = 'CP' THEN SETPOS cp
/* Attempt to reset the default public screen */
IF ds ~ = 'DS' THEN CALL SETDEFAULTPUBSCREEN ds
/* Remove temporary assign, if it exists */
IF POS('FooBar:', da || pd) > 0 THEN SHELL COMMAND 'Assign FooBar: REMOVE'
/* Clean up, if needed */
IF tm ~ = 'TM' THEN DO
/* Attempt to close a possible tempfile... */
CALL CLOSE tm
/* ...and delete it afterwards */
CALL DELETE tm
END
/* Exit the program with the given return value */
EXIT du
_____________________________________________________________
MicroDot-Mailing-Liste - Info & Archiv: http://www.vapor.com/
ML-Hilfe: <[EMAIL PROTECTED]>, Inhalt "HELP"
ML-Abbestellen: <[EMAIL PROTECTED]>, "UNSUBSCRIBE"
