/* -*- REXX -*- */

/* @@PLEAC@@_NAME */
/* @@SKIP@@ REXX @@SKIP@@ */

/* @@PLEAC@@_WEB */
/* @@SKIP@@ http://www.rexxla.org/ @@SKIP@@ */

/* @@PLEAC@@_INTRO */
/* @@SKIP@@  REXX is an interpreted, general purpose programming language that     @@SKIP@@ */
/* @@SKIP@@  is used for both system and applications programming, as well as      @@SKIP@@ */
/* @@SKIP@@  scripting tasks on a number of platforms ranging from mainframes      @@SKIP@@ */
/* @@SKIP@@  to hand-held devices.                                                 @@SKIP@@ */
/* @@SKIP@@                                                                        @@SKIP@@ */
/* @@SKIP@@  ANSI Standard of the REXX language released in 1996. The language has @@SKIP@@ */
/* @@SKIP@@  undergone extensive development over time, and is now available in    @@SKIP@@ */
/* @@SKIP@@  two flavours:                                                         @@SKIP@@ */
/* @@SKIP@@                                                                        @@SKIP@@ */
/* @@SKIP@@  * REXX or 'classic' REXX                                              @@SKIP@@ */
/* @@SKIP@@  * Object Oriented REXX or ooREXX                                      @@SKIP@@ */
/* @@SKIP@@                                                                        @@SKIP@@ */
/* @@SKIP@@  The difference between these two flavours can be likened to that      @@SKIP@@ */
/* @@SKIP@@  between the C, and C++ languages: syntactically similar, but the      @@SKIP@@ */
/* @@SKIP@@  latter extended to support object oriented programming.               @@SKIP@@ */
/* @@SKIP@@                                                                        @@SKIP@@ */
/* @@SKIP@@  More information is available at: http://en.wikipedia.org/wiki/REXX   @@SKIP@@ */
/* @@SKIP@@                                                                        @@SKIP@@ */
/* @@SKIP@@  Comments about the examples:                                          @@SKIP@@ */
/* @@SKIP@@                                                                        @@SKIP@@ */
/* @@SKIP@@  * Incomplete examples are marked with the relevant PLEAC tags         @@SKIP@@ */
/* @@SKIP@@  * Complete, but untranslateable, examples are so-marked               @@SKIP@@ */
/* @@SKIP@@  * Extensive use of third-party libraries made [see Appendix]          @@SKIP@@ */
/* @@SKIP@@  * Regina 3.3 interpreter used for testing [*NIX and Win32]            @@SKIP@@ */


/* @@PLEAC@@_APPENDIX */
/*
   Some of the libraries used:

   * http://home.interlog.com/~ptjm/software.html
     
     REXXUtil      General Purpose Utilities
                   - System Information
                   - Basic Console Control
                   - File / Directory Manipulation

     REXXMath      Common Mathematical Functions
     RxHash        Associative Array Support
     REXXRe        Regular Expressions 

   * http://rxsock.sourceforge.net/index.html
     RxSock        TCP/IP Sockets

   * http://rexxsql.sourceforge.net/index.html
     REXX/SQL      SQL Library

   * http://rexxtk.sourceforge.net/index.html
     REXX/Tk       TK Toolkit

   * http://rexxcurses.sourceforge.net/index.html
     REXX/Curses   Curses Toolkit

   /* ----------------------------- */

   A REXX script is assumed to commence with the following lines:

     options 'STRICT_ANSI' ; trace 'OFF' ; signal on NOVALUE

     FALSE = 0 ; TRUE = 1 ; NULL = "" ; SPACE = ' ' ; NEWLINE = "0A"X
     NaN = "NaN"

     globals = "sys. env. args. $. FALSE TRUE NULL NEWLINE SPACE NaN"

   /* ----------------------------- */

   REXXToolkit routines [when documented] will appear here

   /* ----------------------------- */

*/


/* @@PLEAC@@_1.0 */
string = '\n'     /* two characters, \ and an n, though not a newline */
string = "\n"     /* two characters, \ and an n, though not a newline */

string = "0A"X                     /* newline character code [hex] */
string = "1010"B                   /* newline character code [binary] */
string = "Newline" "0A"X "here"    /* embedded newline in string */

string = 'Jon ''Maddog'' Orwant'   /* literal single quotes */
string = "Jon ""Maddog"" Orwant"   /* literal double quotes */

string = "Jon 'Maddog' Orwant"     /* embedded literal single quotes */
string = 'Jon "Maddog" Orwant'     /* embedded literal double quotes */

/* ----------------------------- */

/* HERE documents not supported, but multi-line string allowed */
a = "This is a multiline string that is not a HERE document" ,
    "but consists of a series of concatenated strings" ,
    "each on its own line courtesy of the 'comma' which, when" ,
    "it appears as the last, space-separated character on a" ,
    "line, acts as a line continuation character"

/* ----------------------------- */

/* Pseudo implementation of a HERE document */

signal HEREDOC /*
Line 1 ...
Line 2 ...
Line 3
*/

HEREDOC:
  a = NULL
  do i = SIGL + 1
    line = SOURCELINE(i)
    if line = "*/" then leave
    a = a||NEWLINE||line
  end

/* @@PLEAC@@_1.1 */
/* ------------------------------------------------------------------ */
/* * REXX offers string manipulation built-in functions [BIF's] many  */
/*   being equivalent to Perl offerings. However, all REXX BIF's      */
/*   return copies of the transformed string; original is unaltered.  */
/*   Therefore this type of usage is illegal:                         */
/*                                                                    */
/*     SUBSTR(string, offset, count) = newstring                      */
/*                                                                    */
/*   Instead, variable storing original must be reassigned with the   */
/*   altered copy                                                     */
/*                                                                    */
/* * REXX implements PARSE instruction which provides a faster means  */
/*   of:                                                              */
/*   - tokenising strings [from several sources: string, file, stack] */
/*   - assigning tokens to variables                                  */
/*   - initialisng and swapping variables, multi-line assignments     */
/*                                                                    */
/* Examples of both approaches shown wherever applicable              */
/* ------------------------------------------------------------------ */

string = "a value"

/* ----------------------------- */

offset = 3 ; count = 9 ; padchar = 'X'

parse var string =(offset) v
v = SUBSTR(string, offset)                     /* "value    " */

parse var string =(offset) v +(count)
v = SUBSTR(string, offset, count)              /* "value    " */

v = SUBSTR(string, offset, count, padchar)     /* "valueXXXX" */

/* ----------------------------- */

offset = 2 ; count = 2 ; padchar = '*' ; newstr = "Z"

v = INSERT(newstr, string, offset, count, padchar)  /* "a Z*value" */
v = OVERLAY(newstr, string, offset, count, padchar) /* "aZ*alue" */

/* ----------------------------- */

/* *** Unfinished *** - UNPACK   */

/* ----------------------------- */

/* PARSE VAR instruction equivalent, but more efficient, than SUBSTR */
string = "This is what you have"
slen = LENGTH(string)

parse var string =1 first +1
first = SUBSTR(string, 1, 1)                           /* "T" */

parse var string =6 start +2
start = SUBSTR(string, 6, 2)                           /* "is" */

parse var string =14 rest
rest = SUBSTR(string, 14)                              /* "you have" */

parse var string =(slen) last +1
last = SUBSTR(string, slen, 1)                         /* "e" */

parse var string =(slen) -3 end
end = SUBSTR(string, slen - 3)                         /* "have" */

parse var string =(slen) -7 piece +3
piece = SUBSTR(string, slen - 7, 3)                    /* "you" */

/* Display contents of string */
say string

/* Change "is" to "wasn't" : This wasn't  what you have */
string = CHANGEWORD("is", string, "wasn't")

/* Replace last 12 characters : This wasn't wondrous */
newstr = "ondrous" ; slen = LENGTH(string) ; nlen = LENGTH(newstr)

/* 1 - slow */
string = OVERLAY(newstr, string, slen - 11)
string = DELSTR(string, LASTPOS(newstr, string) + nlen) 

/* 2 - faster */
string = LEFT(string, slen - 12) || newstr

/* 3 - fastest */
sparse = slen - 12
parse var string string +(sparse)
string = string || newstr

/* delete first character : his wasn't wondrous */
parse var string =2 string
string = DELSTR(string, 1, 1)
string = RIGHT(string, slen - 1)

/* Return last 15 characters : wasn't wondrous */
slen = LENGTH(string)
parse var string =(slen) -14 string +15
string = SUBSTR(string, slen - 14, 15)
string = RIGHT(string, 15)

/* Delete last 10 characters : wasn' */
slen = LENGTH(string) ; sparse = slen - 10
parse var string string +(sparse)
string = DELSTR(string, slen - 9, 10)
string = LEFT(string, slen - 10)

/* *** Unfinished *** */

/* @@PLEAC@@_1.2 */
/* ------------------------------------------------------------------ */
/* REXX Boolean values are strictly:                                  */
/*                                                                    */
/*   1 - TRUE                                                         */
/*   0 - FALSE                                                        */
/*                                                                    */
/* All other values force an syntax error if used in a Boolean        */
/* context; Boolean expression can be forced via a comparision        */
/* operation [see example below]                                      */
/*                                                                    */
/* REXX does not support conditional structures other than the 'IF'   */
/* and 'SELECT' instructions; there is no ternary operator, nor a     */
/* conditional assignment expression. This can, however, be mimiced   */
/* via function; examples below use an 'iif' function implementation  */
/* that, rather crudely, supports this type of operation              */
/*                                                                    */
/* iif(CONDITION, TRUE_VALUE, FALSE_VALUE)                            */
/*                                                                    */
/* It is also worth mentioning that the WORD BIF can also be used for */
/* performing conditional assignment. It can be used where alternate  */
/* values can be placed in the same string, and relies on:            */
/*                                                                    */
/* * The fact that in REXX all data are strings                       */
/* * The values of FALSE and TRUE being exactly 0, and 1, respectively*/
/*                                                                    */
/* See example at end of this section                                 */
/* ------------------------------------------------------------------ */

condition = TRUE ; b = 'B' ; c = 'C' ; x = TRUE ; y = 'Y'

/* Use 'b' if 'condition' is TRUE, else return 'c' */
a = iif(condition, b, c)

/* Use 'b' if 'b' is TRUE, else 'c' */
a = iif(, b, c) 

/* Set 'x' to 'y' unless 'x' is already TRUE */
x = iif(, \x, y) 

/* As above; Boolean expression forced in case 'x' non-Boolean */
x = iif(, \(x == TRUE), y) 

/* ----------- */

/* Use 'b' if 'b' is defined, else 'c' */
a = iif(SYMBOL('b') == "VAR", b, c)

bar = "ANOTHER VALUE"
foo = iif(SYMBOL('bar') \= "VAR", bar, "DEFAULT VALUE")

exit 0

/* ----------- */

iif : procedure expose (globals)
  if ARG(1, 'E') then cond = ARG(1) ; else cond = ARG(2)
  if cond == TRUE then return ARG(2) ; else return ARG(3)

/* ----------------------------- */

condition = TRUE ; alternatives = "B C"

/*
    condition: FALSE -> 'B' returned
    condition: TRUE  -> 'C' returned
*/

WORD(alternatives, condition + 1)

/* @@PLEAC@@_1.3 */
/* ------------------------------------------------------------------ */
/* No multiple-assignment support, but PARSE VALUE instruction may be */
/* used to perform:                                                   */
/*                                                                    */
/* * Multiple variable initialisation                                 */
/* * Multiple variable assignment [even swap values without temps]    */
/* ------------------------------------------------------------------ */

parse value 1 2 with VAR1 VAR2
parse value VAR1 VAR2 with VAR2 VAR1

/* ----------------------------- */

a = 1 ; b = 2
temp = a ; a = b ; b = temp

/* ----------------------------- */

parse value 57 72 103 with alpha beta production
parse value beta production alpha with alpha beta production

/* @@PLEAC@@_1.4 */
/* ------------------------------------------------------------------ */
/* REXX is a typeless language: all data are strings. This means:     */
/*                                                                    */
/* * REXX has no notion of objects, or aggregate types like arrays    */
/* * It does not support 'primitive' types, those usually mapped to   */
/*   hardware registers                                               */
/*                                                                    */
/* In order to support mathematical operations, however, strings in   */
/* Base 10 format [containing 0-9, leading + or -, a decimal point,   */
/* exponent indicator 'E' and exponent] are recognised as 'numeric'   */
/* strings in such contexts [whilst hex and binary strings are not].  */
/*                                                                    */
/* The benefit of this approach:                                      */
/*                                                                    */
/* * Simplifies interpreter implementation on new platforms           */
/* * Implicit support for arbitrary precision arithmetic              */
/* * Language kept simple - no declarations, casting or conversions   */
/*                                                                    */
/* A set of conversion BIF's is supplied to facilitate the conversion */
/* of strings to / from various numeric representations, though it is */
/* understood that this is not a type conversion, but a 'form'        */
/* conversion, one that may facilitate data printing or storage:      */
/*                                                                    */
/* * C2D / D2C [Character to Decimal / vice versa]                    */
/* * C2X / X2C [Character to Hex / vice versa]                        */
/* * X2B / B2X [Hex to Binary / vice versa]                           */
/* ------------------------------------------------------------------ */

char = 'A'                            /* or: char = '41'X [ASCII] */
num = C2D(char)
char = D2C(num)

/* ----------------------------- */

char = 'e'
say "Number" C2D(char) "is" char      /* Number 101 is e */

/* ----------------------------- */

string = "ABCDE"
ascii = C2X(string)                   /* ascii [hex]: 4142434445 */
string = X2C(ascii)                   /* string: ABCDE */

/* ----------------------------- */

/* Contents: 73616D706C65 */ 
ascii_character_numbers = C2X("sample")

/* Output will now be: 73 61 6D 70 6C 65 */ 
out = "" ; acn = ascii_character_numbers
do while acn <> NULL
  parse var acn token +2 acn
  out = out token
end
say STRIP(out)

/* Output will now be: sample */ 
out = X2C(ascii_character_numbers)
say out

/* ----------------------------- */

hal = "HAL" ; ibm = ""

do while hal <> NULL
  parse var hal token +1 hal
  ibm = ibm||D2C(C2D(token) + 1)
end 

/* Output will now be: IBM */ 
say ibm

/* @@PLEAC@@_1.6 */
/* ------------------------------------------------------------------ */
/* The task of reversing strings is easily and efficiently performed  */
/* via the REVERSE BIF. Implementation of a palindome-checking routine*/
/* is probably best accomplished via its use since it involves a      */
/* single function call, thus incurs minimal calling overhead. Since  */
/* REXX is typically used as an interpreted language, it often becomes*/
/* a significant issue. Performance comparision of the following two  */
/* 'isPalindrome' functions should clearly reveal it's impact.        */
/*                                                                    */
/* isPalindrome : procedure                                           */
/*   i = 1 ; j = LENGTH(ARG(1))                                       */
/*   do until i >= j                                                  */
/*     if SUBSTR(ARG(1),i,1) \= SUBSTR(ARG(1),j,1) ; then return FALSE*/
/*     i = i + 1 ; j = j - 1                                          */ 
/*   end                                                              */
/*   return TRUE                                                      */ 
/*                                                                    */
/* isPalindrome : procedure                                           */
/*   return REVERSE(ARG(1)) == ARG(1)                                 */
/*                                                                    */
/* The task of reversing words within a string can quite easily be    */
/* accomplished in several ways:                                      */
/*                                                                    */
/* * PARSE instruction together with the stack operations PUSH and    */
/*   PARSE PULL [stack and queue structures are native to REXX, and   */
/*   are used for many diverse tasks including interprocess comms]    */
/*                                                                    */
/* * Word-oriented BIF's ['reverseWords' is a recursive function that */
/*   uses two of these: DELWORD and WORD. Anyone familiar with LISP or*/
/*   Scheme will note how they are being used like 'car' and cdr']    */ 
/*                                                                    */
/* reverseWords : procedure                                           */ 
/*   if ARG(1) == "" then ; return ""                                 */
/*   return STRIP(reverseWords(DELWORD(ARG(1), 1, 1)) WORD(ARG(1), 1))*/
/* ------------------------------------------------------------------ */

string = "A horse is a horse, of course, of course !"

/* Reverse string using REXX BIF */
revbytes = REVERSE(string)

/* ----------------------------- */

/* Tokenise 'string', and place each token on stack */
do while string <> NULL
  parse var string token string
  push token
end

/* Build 'revwords' by extracting tokens from stack */
revwords = ""
do while QUEUED() > 0
  parse pull token
  revwords = revwords token 
end

/* ----------------------------- */

string = 'Yoda said, "can you see this?"'

/* Reverse the word order in a string [custom function - see header] */
revwords = reverseWords(string)
say revwords

/* ----------------------------- */

word = "reviver"

/* Check whether string is palindrome [custom function - see header] */
is_palindrome = isPalindrome(word)


/* @@PLEAC@@_2.0 */
/* ------------------------------------------------------------------ */
/* REXX uses floating point-based, arbitrary precision arithmetic     */
/* which, unlike most computer languages, operates not on hardware-   */
/* mapped bit collections, but on strings which represent numbers.    */
/*                                                                    */
/* The immediately-obvious disadvantage of this approach is slower,   */
/* less memory-efficient number crunching capabilities when compared  */
/* to scripting languages like Perl or Python. On the other hand, this*/
/* design approach simplifies REXX interpreter implementation across  */
/* platforms, as well as eliminating most of the loss-of-precision and*/
/* related problems so often encountered when 'number crunching'. So, */
/* from an end-user perspective, arithmetic operations should nearly  */
/* always generate 'unsurprising' results, and not cause the naive or */
/* unwary user any confusion.                                         */
/* ------------------------------------------------------------------ */

/* @@PLEAC@@_2.1 */
/* ------------------------------------------------------------------ */
/* The REXX-idiomatic numeric validation approach is to use the       */
/* 'DATATYPE' BIF. For more complex validation needs the 'VERIFY' BIF */
/* may also be used but since it only checks for the presence or the  */
/* absence of characters it needs to be augmented with other checks.  */
/*                                                                    */
/* Regex-based validation [once implemented] requires the least work. */
/* The examples make use of a REXXToolkit routine, 'match', which     */
/* uses the 'RxRe' external library. See Appendix for details.        */
/* ------------------------------------------------------------------ */

/* REXX BIF-based Validation */

/* Accepts: +9 -9 9.0 9.0e+2 9.0E-3 */
if \DATATYPE(string, 'N') then ; say "not a decimal number"

/* Accepts: +9 -9 Rejects: 9.0 9.0e+2 9.0E-3 */
if \(DATATYPE(string, 'W') & POS(".", string) == 0) then
  say "not an integer"

/* ----------- */

/*
   Checks for presence / absence of characters, but does not
   check position of characters, or presence of patterns. Useful
   for quick, but not thorough, validation
*/

if VERIFY(string, "0123456789") \= 0 then ; say "has nondigits"

if VERIFY(string, "+-.Ee0123456789") \= 0 then ; say "not a decimal"

/* ----------- */

/*
   Custom function, 'isDecimal', which uses a combination of the
   PARSE instruction, and DATATYPE BIF to thoroughly validate a
   decimal value
*/

tbl = "+934.521e-2 -934.521 934 ",
      "+934.521e-a +934.521f-2 +934.!e-2 ",
      "e934.521e-2"

entries = WORDS(tbl)

do i = 1 for entries
  entry = WORD(tbl, i)
  if isDecimal(entry) then ; say entry "is decimal"
  else ; say entry "is NOT decimal"
end

exit 0

/* ----------- */

isDecimal : procedure expose (globals)
  parse upper value ARG(1) with whole "." frac "E" exp
  if exp \= NULL then ; if \DATATYPE(exp, 'W') then ; return FALSE
  if frac \= NULL then ; if \DATATYPE(frac, 'W') then ; return FALSE
  if whole \= NULL then ; if \DATATYPE(whole, 'W') then ; return FALSE
  return TRUE

/* ----------------------------- */

/* Regex-based Validation */

if match(string, "PATTERN") then
  /* Is a number */
else
  /* Is not */

/* ----------- */

/* Also rejects: +9 -9 9.0 */
if match(string, "[^[:digit:]]") then ; say "has nondigits"

/* Also rejects: +9 -9 9.0 */
if \match(string, "^[[:digit:]]+$") then ; say "not a natural number"

/* Rejects: +9 9.0  Accepts: -9 */
if \match(string, "^-?[[:digit:]]+$") then ; say "not an integer"

/* Rejects: 9.0  Accepts: +9 -9 */
if \match(string, "^[+-]?[[:digit:]]+$") then ; say "not an integer"

/* Accepts: +9 -9 9.0 9.0e+2 9.0E-3 */
decimalRE = "^[+-]?[[:digit:]]+\.?[[:digit:]]+[e|E][+-]?[[:digit:]]+$"

if \match(string, decimalRE) then
  say "not a decimal number"

/* @@PLEAC@@_2.2 */
/* ------------------------------------------------------------------ */
/* The NUMERIC instruction allows adjustment of:                      */
/*                                                                    */
/* * Significant digits used in arithmetic operations [DIGITS]        */
/* * Digits to be ignored during arithmetic comparisons [FUZZ]        */
/*                                                                    */
/* Default values are usually adequate. Increasing DIGITS increases   */
/* precision, but slows down arithmetic operations. FUZZ is by default*/
/* 0, so all digits are significant in comparison operations.         */
/*                                                                    */
/* The FORMAT BIF may be used like the C-derived, 'sprintf', function */
/* to compare floating point values as strings.                       */
/* ------------------------------------------------------------------ */

numeric digits 11
a = 1234567.8234 ; b = 1234567.8237

/* Compare 'DIGITS - FUZZ' [11] number of digits */
numeric fuzz 0
if a = b then ; say "a = b"          /* FALSE */

/* Compare 'DIGITS - FUZZ' [10] number of digits */
numeric fuzz 1
if a = b then ; say "a = b"          /* FALSE */

/* Compare 'DIGITS - FUZZ' [9] number of digits */
numeric fuzz 2
if a = b then ; say "a = b"          /* TRUE */

/* ----------------------------- */

/*
   Returns TRUE if 'num1' and 'num2' are equal to 'accuracy' number
   of decimal places
*/

isEqual(num1, num2, accuracy)

/* ----------------------------- */

a = 1234567.8234 ; b = 1234567.8237

/*
   isEqual(a, b, 1) ==> TRUE
   isEqual(a, b, 2) ==> TRUE
   isEqual(a, b, 3) ==> TRUE
   isEqual(a, b, 4) ==> FALSE
*/

exit 0

/* ----------- */

isEqual : procedure expose (globals)
  places = ARG(3) ; numeric fuzz 0
  return FORMAT(ARG(1),, places) == FORMAT(ARG(2),, places)

/* ----------------------------- */

wage = 536                           /* $ 5.36 / hr */
week = 40 * wage                     /* $ 214.40 */

say "One week's wage is: $" FORMAT(week / 100,, 2)

/* @@PLEAC@@_2.3 */
/* ------------------------------------------------------------------ */
/* The 'FORMAT' BIF is REXX's equivalent to the much-used, C-derived  */
/* 'sprintf' function.                                                */
/* ------------------------------------------------------------------ */

/* Truncate to integer value */
truncated = TRUNC(value, length)

/* Round value [and possibly justify] */
rounded = FORMAT(value, n_before_decimal, n_after_decimal)

/* ----------------------------- */

a = 0.255 ; b = FORMAT(a, 1, 2)

say "Unrounded:" a "Rounded:" b
say "Unrounded:" a "Rounded:" FORMAT(a, 1, 2)

/*
   Unrounded: 0.255 Rounded: 0.26
   Unrounded: 0.255 Rounded: 0.26
*/

/* ----------------------------- */

/*
   Example illustrating external library routine use. Not, however,
   that the FORMAT BIF can be used to perform the same tasks as
   'NInt', 'Floor' and 'Ceil', making library routine use unnecessary
*/

/* Load [rexxMath] math functions from external library */
call rxFuncAdd 'mathLoadFuncs', 'rexxMath', 'mathLoadFuncs'
call mathLoadFuncs

tbl = "3.3 3.5 3.7 -3.3"

say cstr2rxstr("number\tint\tfloor\tceil")

do while tbl <> NULL
  parse var tbl n tbl
  line = FORMAT(n, 2, 1) || "\t" ||,
         FORMAT(NInt(n), 2, 1) || "\t" ||,
         FORMAT(Floor(n), 2, 1) || "\t" ||,
         FORMAT(Ceil(n), 2, 1)
  say cstr2rxstr(line)
end

/*
   number int floor ceil
    3.3          3.0     3.0     4.0
    3.5          4.0     3.0     4.0
    3.7          4.0     3.0     4.0
   -3.3         -3.0    -4.0    -3.0
*/

/* Unload math functions */
call mathDropFuncs

exit 0

/* ----------- */

cstr2rxstr : procedure expose (globals)
  s = ARG(1) ; tbl = "\n 0A \r 0D \t 09"

  do while tbl \= NULL
    parse var tbl esc replc tbl
    s = CHANGESTR(esc, s, X2C(replc))
  end

  return s

/* @@PLEAC@@_2.4 */
/* ------------------------------------------------------------------ */
/* Binary, hexadecimal, decimal interconversion is well-supported via */
/* the following BIF's:                                               */
/*                                                                    */
/* * X2D, D2X [hex->dec, dec->hex, respectively]                      */
/* * X2B, B2X [hex->bin, bin->hex, respectively]                      */
/*                                                                    */
/* Easily combined to create functions that interconvert binary and   */
/* decimal.                                                           */
/* ------------------------------------------------------------------ */

/* Convert binary string to decimal */
decimal = B2D('0110110')

/* Convert decimal value to binary string */
binary = D2B(54)

exit 0

/* ----------- */

B2D : procedure expose (globals)
  return X2D(B2X(ARG(1)))

D2B : procedure expose (globals)
  return X2B(D2X(ARG(1)))

/* @@PLEAC@@_2.5 */
/* ------------------------------------------------------------------ */
/* The 'do' loop is the REXX-idiomatic control structure for          */
/* repetitive tasks such as list traversal. Recursive solutions are   */
/* possible but less efficient due to argument passing overhead, and  */
/* lack of tail-call optimisation.                                    */
/* ------------------------------------------------------------------ */

x = 1 ; y = 5 ; step = 1

/* Number sequence is traversed using 'do' loop */

/* 'i' set from value of 1 through to 5 in 'step' increments */
do i = x to y by step

  /* do something with 'i' */

end

/* ----------- */

/* 'i' set from value of 1 through to 5; default increment of 1 */
do i = x to y

  /* do something with 'i' */

end

/* ----------------------------- */

call CHAROUT , "Infancy is: "
do i = 0 to 2 ; call CHAROUT , i || SPACE ; end
say NULL

call CHAROUT , "Toddling is: "
do i = 3 to 4 ; call CHAROUT , i || SPACE ; end
say NULL

call CHAROUT , "Childhood is: "
do i = 5 to 12 ; call CHAROUT , i || SPACE ; end
say NULL

/* ----------------------------- */

/*
   REXX does not sport a native 'foreach' control structure, but it
   is possible to implement similar behaviour provided certain
   conventions are followed such as generating lists of SPACE or
   COMMA-separated sequences
*/

/* ----------------------------- */

sequence = makeIntegerSequence(1, 5, 1)

do while sequence <> NULL
  parse var sequence value sequence
  call CHAROUT , value || SPACE
end

/* ----------- */

/* Partial reimplementation of earlier example */

infancy = makeIntegerSequence(0, 2, 1)

call CHAROUT , "Infancy is: "
do while infancy <> NULL
  parse var infancy value infancy
  call CHAROUT , value || SPACE
end

/* ... */

exit 0

/* ----------- */

/* Iterative ['do' loop-based] */
makeIntegerSequence : procedure expose (globals)
  x = ARG(1) ; y = ARG(2) ; step = ARG(3)
  seq = x ; x = x + 1 ; do i = x to y by step ; seq = seq i ; end
  return seq

/* Recursive */
makeIntegerSequenceR : procedure expose (globals)
  x = ARG(1) ; y = ARG(2) ; step = ARG(3)
  if x > y then ; return NULL
  return x makeIntegerSequenceR(x + step, y, step)

/* Iterative [Tail Recursive] */
makeIntegerSequenceI : procedure expose (globals)
  x = ARG(1) ; y = ARG(2) ; step = ARG(3) ; seq = ARG(4)
  if x > y then ; return STRIP(seq)
  return makeIntegerSequenceI(x + step, y, step, (seq x))

/* @@PLEAC@@_2.6 */
/* ------------------------------------------------------------------ */
/* REXX sports no inbuilt Roman numeral-handling routines. A custom   */
/* implementation appears below.                                      */
/* ------------------------------------------------------------------ */

roman = arabic2roman(arabic)
arabic = roman2arabic(roaman)

/* ----------------------------- */

roman_fifteen = arabic2roman(15)

say "Roman for fifteen is" roman_fifteen

arabic_fifteen = roman2arabic(roman_fifteen)

say "Converted back" roman_fifteen "is" arabic_fifteen

exit 0

/* ----------- */

roman2arabic : procedure
  tbl.I = 1 ; tbl.V = 5 ; tbl.X = 10 ; tbl.L = 50
  tbl.C = 100 ; tbl.D = 500 ; tbl.M = 1000 

  tbl.IV = 4 ; tbl.IX = 9 ; tbl.XL = 40 ; tbl.XC = 90
  tbl.CD = 400 ; tbl.CM = 900

  roman = " " || TRANSLATE(STRIP(ARG(1))) ; arabic = 0

  do i = LENGTH(roman) - 1 to 1 by -1
    r = SUBSTR(roman, i, 2)

    if SYMBOL('tbl.r') == 'VAR' then ; i = i - 1
    else ; r = RIGHT(r, 1)

    arabic = arabic + tbl.r
  end

  return arabic

/* ----------- */

arabic2roman : procedure
  arabic = REVERSE(ARG(1)) ; len = LENGTH(arabic) ; roman = ""

  tbl.1 = "I II III IV V VI VII VIII IX"
  tbl.2 = "X XX XXX XL L LX LXX LXXX XC"
  tbl.3 = "C CC CCC CD D DC DCC DCCC CM"

  if len < 4 then
    do i = 1 to len
      j = SUBSTR(arabic, i, 1) ; if j == 0 then ; iterate 
      roman = WORD(tbl.i, j) || roman 
    end
  else ; do
    do i = 1 to 3
      j = SUBSTR(arabic, i, 1) ; if j == 0 then ; iterate 
      roman = WORD(tbl.i, j) || roman 
    end
    roman = COPIES("M", REVERSE(SUBSTR(arabic, 4))) || roman
  end

  return roman

/* @@PLEAC@@_2.7 */
/* ------------------------------------------------------------------ */
/* Random number [well, pseudo-random :)] generation is typically     */
/* performed using the 'RANDOM' BIF.                                  */
/* ------------------------------------------------------------------ */

random = RANDOM(maxval)              /* 0 - maxval [maxval <= 100000] */
random = RANDOM(minval, maxval)      /* minval - maxval [as above] */

/* ----------------------------- */

tbl = "abcdefghijklmnop"
elt = randomChoice(tbl)              /* One of 'a', 'b', ... */

tbl = "12 67 asde cvs +++ &fgt klmnop"
elt = randomChoice(tbl)              /* One of 12, 67, ... */

/* ----------------------------- */

/* Generate 8 character-length password with randomly chosen chars */
chars = XRANGE("A", "Z") || XRANGE("a", "z") ||,
        XRANGE("0", "9") || "!$%#@*&"

password = NULL

do 8
  password = password || randomChoice(chars)
end

exit 0

/* ----------- */

randomChoice : procedure expose (globals)
  tbl = ARG(1) ; items = WORDS(tbl)

  if items == 1 then do
    items = LENGTH(tbl) ; item = SUBSTR(tbl, RANDOM(1, items), 1)
  end ; else do
    item = WORD(tbl, RANDOM(1, items))
  end

  return item

/* @@PLEAC@@_2.8 */
/* ------------------------------------------------------------------ */
/* See comments in previous section                                   */
/* ------------------------------------------------------------------ */

random = RANDOM(,, seed)   /* Each such call reseeds the RNG */

/* @@PLEAC@@_2.9 */
/* ------------------------------------------------------------------ */
/* Custom functions for this type of task are easily written in REXX. */
/* Examples include:                                                  */
/*                                                                    */
/* * 'lcg', simple linear-congruential RNG                            */
/* * 'randomSlice' - see example below                                */
/* ------------------------------------------------------------------ */

random = 47523 ; reps = 10

do reps
  random = lcg(random)
  /* do something with 'random' ... */
end

/* ----------------------------- */

reps = 10

do reps
  /*
     Random length digit sequence; sliced from random position of a
     default-length 'RANDU'-generated digit sequence
  */
  random = randomSlice()

  /* 3 digit sequence; as previous  */
  random = randomSlice(3)

  /*
     4 digit sequence; sliced from random position of a 13 digit
     length 'RANDU'-generated digit sequence
  */
  random = randomSlice(4, 13)
end

/* ----------- */

lgc : procedure expose (globals)
  numeric digits 17
  return 16807 * ARG(1) // 2147483647

randomSlice : procedure expose (globals)
  sizeSlice = ARG(1) ; sizePool = ARG(2)
  if sizePool == NULL | sizePool > 17 then ; sizePool = 17
  if sizeSlice == NULL then ; sizeSlice = RANDOM(1, sizePool - 1)
  if sizeSlice >= sizePool then ; sizeSlice = sizePool - 1;
  posSlice = RANDOM(1, sizePool - sizeSlice)
  numeric digits sizePool
  parse value RANDU() with "." frac
  return SUBSTR(frac, posSlice, sizeSlice)

/* @@PLEAC@@_2.10 */
/* ------------------------------------------------------------------ */
/* Gaussian RNG                                                       */
/* ------------------------------------------------------------------ */

/* Need this for access to non-standard, 'RANDU', function */ 
options 'AREXX_BIFS'

/* Using 'rexxMath' Library Routines */

/* Load [rexxMath] math functions from external library */
call rxFuncAdd 'mathLoadFuncs', 'rexxMath', 'mathLoadFuncs'
call mathLoadFuncs

/* ----------- */

mean = 25.0 ; sdev = 2.0 ; salary = gaussian_rand() * mean + sdev

say "You have been hired at:" FORMAT(salary,, 2)

/* ----------- */

/* Unload math functions */
call mathDropFuncs

exit 0

/* ----------- */

gaussian_rand : procedure
  w = 2.0
  
  do while w > 1.0
    u1 = 2.0 * RANDU() - 1.0 ; u2 = 2.0 * RANDU() - 1.0
    w = u1 * u1 + u2 * u2
  end
  
  w = Sqrt((-2.0 * Log10(w)) / w) ; g2 = u1 * w ; g1 = u2 * w

  return g1

/* @@PLEAC@@_2.11 */
/* ------------------------------------------------------------------ */
/* Aside from supporting the usual arithmetic operations, including   */
/* exponentiation [via the '**' operator], and a few BIF's including  */
/* 'MIN', 'MAX', 'SIGN' and 'ABS', REXX offers no built-in support for*/
/* mathematical operations. Instead the programmer can implement the  */
/* required functionality themselves, or make use of external library */
/* routines.                                                          */
/*                                                                    */
/* REXX-native mathematical functions are easily implementable, but   */
/* the string-expressable, arbitrary precision arithmetic model used  */
/* ensures they will not be as 'high performance' as hardware-based   */
/* implementations, precluding their use for 'serious' number crunch- */
/* ing. On the other hand, external library routines are [like the one*/
/* illustrated here] to be hardware-based, hence offer performance    */
/* comparable to that of other languages after both function call and */
/* data conversion overhead is taken into account.                    */
/* ------------------------------------------------------------------ */

/* Using 'rxMath' Library Routines */

/* Load [rxMath] math functions from external library */
call rxFuncAdd 'mathLoadFuncs', 'rxMath', 'mathLoadFuncs'
call mathLoadFuncs

/* Accepts argumets in either degree, radian, or gradian form */
say rxCalcSin(30, 'D')
say FORMAT(rxCalcSin(60, 'D'),,3)

/* Unload math functions */
call mathDropFuncs

exit 0

/* ----------- */

/* Using native REXX Routines [need 'Sin' from external library] */

radians = DEG2RAD(degrees)
degrees = RAD2DEG(radians)

/* ----------------------------- */

/* Load [rexxMath] math functions from external library */
call rxFuncAdd 'mathLoadFuncs', 'rexxMath', 'mathLoadFuncs'
call mathLoadFuncs

say degree_sin(30)
say FORMAT(degree_sin(60),,3)

/* Unload math functions */
call mathDropFuncs

exit 0

/* ----------- */

degree_sin : procedure expose (globals)
  /*
     ARG(1) - Degrees
     ---
     'Sin' [a 'rexxMath' library routine] expects its argument in
     radians so 'DEG2RAD' used to perform the conversion
  */
  return Sin(DEG2RAD(ARG(1)))

DEG2RAD : procedure expose (globals)
  return ARG(1) / 180 * PI()

RAD2DEG : procedure expose (globals)
  return ARG(1) / PI() * 180

PI : procedure expose (globals)
  return 3.14159265358979323846264338327

/* @@PLEAC@@_2.12 */
/* ------------------------------------------------------------------ */
/* See comments in previous section header                            */
/* ------------------------------------------------------------------ */

/* Using 'rxMath' Library Routines */

/* Load [rxMath] math functions from external library */
call rxFuncAdd 'mathLoadFuncs', 'rxMath', 'mathLoadFuncs'
call mathLoadFuncs

/* Accepts argumets in either degree, radian, or gradian form */
theta = 1.7 ; tan = rxCalcSin(theta, 'R') / rxCalcCos(theta, 'R')

say "tan of theta" theta "[radians]:" tan
say "tan of theta" FORMAT(theta,, 3) "[radians]:" FORMAT(tan,, 3)

/* ----------- */

say "tan of theta" theta "[radians]:" rxCalcTan(theta, 'R')
say "tan of theta" FORMAT(theta,, 3) "[radians]:",

/* ----------- */

theta = 0.37 ; say "acos of" theta "[radians]:" rxCalcArcCos(theta, 'R')

/* ----------- */

/* Unload math functions */
call mathDropFuncs

exit 0

/* ----------------------------- */

/* Using 'rexxMath' Library Routines */

/* Load [rexxMath] math functions from external library */
call rxFuncAdd 'mathLoadFuncs', 'rexxMath', 'mathLoadFuncs'
call mathLoadFuncs

theta = 1.7 ; tan = Sin(theta) / Cos(theta)

say "tan of theta" theta "[radians]:" tan
say "tan of theta" FORMAT(theta,, 3) "[radians]:" FORMAT(tan,, 3)

/* ----------- */

say "tan of theta" theta "[radians]:" Tan(theta)
say "tan of theta" FORMAT(theta,, 3) "[radians]:" FORMAT(Tan(theta),, 3)

/* ----------- */

theta = 0.37 ; say "acos of" theta "[radians]:" ACos(theta)

/* ----------- */

/* Unload math functions */
call mathDropFuncs

exit 0

/* @@PLEAC@@_2.13 */
/* ------------------------------------------------------------------ */
/* See comments in previous section header                            */
/* ------------------------------------------------------------------ */

/* Using 'rxMath' Library Routines */

/* Load [rxMath] math functions from external library */
call rxFuncAdd 'mathLoadFuncs', 'rxMath', 'mathLoadFuncs'
call mathLoadFuncs

log_e = rxCalcLog(value)

/* ----------- */

log_10 = rxCalcLog10(value)

/* ----------- */

answer = rxlog_base(10, 10000)

say "log_base(10, 10000) ==>" FORMAT(answer,, 2)
say "log10(10000)        ==>" FORMAT(rxCalcLog10(10000),, 2)

/* ----------- */

/* Unload math functions */
call mathDropFuncs

exit 0

/* ----------- */

rxlog_base : procedure expose (globals)
  base = ARG(1) ; value = ARG(2)
  return rxCalcLog(value) / rxCalcLog(base)

/* ----------------------------- */

/* Using 'rexxMath' Library Routines */

/* Load [rexxMath] math functions from external library */
call rxFuncAdd 'mathLoadFuncs', 'rexxMath', 'mathLoadFuncs'
call mathLoadFuncs

log_e = Log(value)

/* ----------- */

log_10 = Log10(value)

/* ----------- */

answer = log_base(10, 10000)

say "log_base(10, 10000) ==>" FORMAT(answer,, 2)
say "log10(10000)        ==>" FORMAT(Log10(10000),, 2)

/* ----------- */

/* Unload math functions */
call mathDropFuncs

exit 0

/* ----------- */

log_base : procedure expose (globals)
  base = ARG(1) ; value = ARG(2)
  return Log(value) / Log(base)

/* @@PLEAC@@_2.14 */
/* ------------------------------------------------------------------ */
/* REXX offers no matrix-handling BIF's. Below can be found a custom  */
/* implementation that, perhaps unusually, represents matrices as str-*/
/* ings. Notes:                                                       */
/*                                                                    */
/* * Since strings are immutable, matrix manipulations result in new  */
/*   strings being created; high performance, therefore, should not be*/
/*   expected                                                         */
/*                                                                    */
/* * Only a smattering of operations are offered, and some of them use*/ 
/*   rather naive algorithms [e.g. multiplication - Winograd's algori-*/
/*   thm could instead be used]                                       */
/*                                                                    */
/* * There is much code redundancy [e.g. 'madd' and 'msub' are identi-*/
/*   save for the arithmetic operation performed]. This could have be-*/
/*   en avoided via use of both the VALUE BIF and INTERPRET instructi-*/
/*   on [an approach much used in Chapter 4], but it was felt that co-*/
/*   de would be more readable, and perhaps more easily adapted if ke-*/
/*   pt simple, despite the repetition.                               */
/*                                                                    */
/* * Decision to model matrices as strings was based on two factors:  */
/*                                                                    */
/*   - Avoiding global array use                                      */
/*   - Illustrate how ADT's may be modelled using strings, and showca-*/
/*     se the REXX PARSE instruction and string manipulation BIF's    */
/*                                                                    */
/* Performance can be significantly improved without resorting to the */
/* use of global arrays by using an external library like T. J. McPhe-*/
/* e's, 'rxHash', that implements arrays as special strings that may  */
/* be freely passed around. Chapter 4 makes extensive use of this very*/
/* versatile library. I hope to provide an expanded version of the    */
/* present library using this technique as part of the REXXToolkit [to*/
/* be found in the Appendix] sometime in 2007.                        */
/* ------------------------------------------------------------------ */

/* Global Constants */
FALSE = 0 ; TRUE = 1 ; NULL = "" ; NEWLINE = "0A"X ; SPACE = ' '
NaN = "NaN"

/* Matrix-specific global constants */
MTAG = "<M>" ; MHSEP = "|" ; MRAWSEP = "; " ; MRSEP = ";"

MTYPE_REGULAR = "R" ; MTYPE_SINGULAR = "S" ; MTYPE_ZERO = "Z"
MTYPE_IDENTITY = "I" ; MTYPE_VECTOR = "V"

/* -- */

/* Global Roots and 'expose' list */
globals = "sys. env. args. $. FALSE TRUE NULL NEWLINE SPACE NaN"

/* Matrix-specific 'expose' list */
matdefs = "MTAG MHSEP MTYPE_REGULAR MTYPE_SINGULAR" ,
          "MTYPE_ZERO MTYPE_IDENTITY MTYPE_VECTOR" ,
          "MRSEP" ,
          "MRAWSEP"

/* ----------------------------- */

x = makeMatrix("3 2 3;5 9 8;") ; y = makeMatrix("4 7;9 3;8 1;")

z = mmul(x, y)

say "z =" ; call mdump z

/* ----------------------------- */

say "z determinant:" mdet(z)

say "z inverse =" ; call mdump minverse(z), 8

say "trace:      " mtrace(z)

say "z transpose =" ; call mdump mtranspose(z)

exit 0

/* ----------------------------- */

/*
   * *** IMPORTANT ***
     Matrix rows and columns numbered from 1, and *not* 0 like so
     many zero-index-based languages

   * Variable size, delimited strings represent the matrix type.
     Each such string has a header section followed by a data
     section; typically, the string is split, metadata extracted
     from the header, and the data section returned for subsequent
     processing

   * Easy to view matrix contents: just SAY the string. The 'mdump'
     routine is available for pretty printing

   * Simple error-handling approach used: a value of, 'NaN', is
     returned where any error is detected [applies only to routines
     that do error checking - 'stupid' usage merely sees the script
     crash]

   * Matrix Format [EBNF]:

     <matrix> ::= <header> <data>

          <header> ::= <type-tag> <rows> <columns> <matrix-type> <EOH>
            <data> ::= <row>+

        <type-tag> ::= '<M>'
            <rows> ::= <integer>
          <colums> ::= <integer>
     <matrix-type> ::= 'S' | 'R' | 'V' | 'Z' | 'I'
             <EOH> ::= '|'

             <row> ::= <decimal>+ <EOR>
             <EOR> ::= ';'

         <integer> ::= digit+
         <decimal> ::= <integer> | digit+ '.' digit+
           <digit> ::= '0' | '1' | '2' | '3' | '4' | '5' | '6' | '7'
                     | '8' | '9'

   * Matrix Format Examples:

     - 1-row matrices considered vectors
       1x1 -> "<M>1 1 V|7;"
       1x3 -> "<M>1 3 V|7 8 9;"

     - Square Matrices; regular, zero, or identity
       2x2 Regular  -> "<M>2 2 R|1 2;4 5;"
       3x3 Regular  -> "<M>3 3 R|1 2 3;4 5 6;7 8 9;"
       3x3 Zero     -> "<M>3 3 Z|0 0 0;0 0 0;0 0 0;"
       3x3 Identity -> "<M>3 3 I|1 0 0;0 1 0;0 0 1;"

     - Singular Matrices
       2x3 -> "<M>2 3 S|1 2 3;4 5 6;"
       3x2 -> "<M>3 2 S|1 2;3 4;5 6;"

   * Matrix string contains both metadata and uses a delimiter to
     mark out rows. Using only one of these items would have allowed
     determination of the other [i.e. compute metadata by counting
     delimiters, or tokenise into rows using metadata], but using both
     allowed for easy type-checking and simplified tokenisation via
     the PARSE instruction

   * Routines classed as follows:

     - Constructors [makeVector, makeMatrix, makeDiagonal]
     - Type Checkers [isVector, isMatrix, is1x1, is2x2]
     - Metadata [mrows, mcols]
     - Comparators [meql]
     - Selectors [extractMatrix, mrow, mcol, msubset, mminor]
     - Matrix Arithmetic [madd, msub, mmul, mdiv]
     - Matrix OPerations [mtranspose, mcofactor, mdet1x1, mdet2x2,
       mdet, minv1x1, minverse, mtrace]
     - Elementary Row / Column Operations [mswapc, mswapr, maddc,
       maddr, mmulc, mmulr]. These are needed for solving linear
       equations via Echelon method
     - Pretty Print [mdump]

   * Routine documentation has the following structure:

       Parameter List
       ---
       Description
       ---
       Routine Example(s)

       Parameter list conventions include:
       - x | y | z -> One of x or y or z
       - [optional arguments ...]
       - Types:
         + s, s1, s2 -> string(s)
         + n, n1, n2 -> numeric
         + v, v1, v2 -> vector(s)
         + m, m1, m2 -> matrices
*/

/* ----------- */

makeVector : procedure expose (globals) (matdefs)
  /*
     s | n1 [, n2, ...]
     ---
     Returns a vector created by parsing, 's', or assembling, 'n1',
     'n2' ...
     ---
     v = makeVector("1 2 3;")
     v = makeVector(1, 2, 3)
  */
  argc = ARG() ; if argc == 0 then ; return NaN
  if argc == 1 then do
    v = ARG(1) ; argc = WORDS(v)
  end ; else do
    v = NULL ; do i = 1 for argc ; v = v ARG(i) ; end ; v = STRIP(v)
  end
  return MTAG || 1 argc MTYPE_VECTOR || MHSEP || v || MRSEP

makeMatrix : procedure expose (globals) (matdefs)
  /*
     s | v1 [, v2, ...]
     ---
     Returns a matrix created by parsing, 's', or assembling, 'v1',
     'v2' ...
     ---
     m = makeMatrix("1 2 3;4 5 6;7 8 9;")
     m = makeMatrix(makeVector(1, 2, 3))
     m = makeMatrix(makeVector(1, 2, 3), makeVector(4, 5, 6),,
         makeVector(7, 8, 9))
  */
  argc = ARG() ; if argc == 0 then ; return NaN
  if argc == 1 then do
    m = ARG(1) ; if isVector(m) then ; return m
    rows = COUNTSTR(MRSEP, m)
    cols = WORDS(SUBSTR(m, 1, POS(MRSEP, m) - 1))
    rv = NULL ; do i = 1 for rows
      parse var m row (MRSEP) m ; rv = rv || row || MRSEP
    end
  end ; else do
    rows = argc ; rv = NULL ; do i = 1 for rows
      parse value ARG(i) with (MTAG) . cols . (MHSEP) data
      rv = rv || data
    end
  end
  select
    when cols == rows then ; type = MTYPE_REGULAR
    otherwise ; type = MTYPE_SINGULAR
  end
  return MTAG || rows cols type || MHSEP || STRIP(rv)

makeDiagonal : procedure expose (globals) (matdefs)
  /*
     s | v | n1 [, n2, ...]
     ---
     Returns a square matrix with a leading diagonal having the values
     obtained by parsing, 's', assembling, 'v1', 'v2', or from, 'v'
     ---
     m = makeDiagonal("1 2 3;")
     m = makeDiagonal(1, 2, 3)
     m = makeDiagonal(makeVector(1, 2, 3))
  */
  argc = ARG() ; if argc == 0 then ; return NaN
  ONE_ONLY = TRUE ; chksum = 0
  if argc == 1 then do
    v = ARG(1) ; if isVector(v) then do
      parse var v (MTAG) . cols . (MHSEP) data
    end ; else do
      cols = WORDS(SUBSTR(v, 1, POS(MRSEP, v) - 1)) ; data = v
    end
    parse var data row (MRSEP) .
    rows = cols ; rv = NULL ; do i = 1 for rows
      do j = 1 for cols
        if i == j then do
          parse var row item row
          chksum = chksum + item ; rv = rv item
          if item > 1 then ; ONE_ONLY = FALSE
        end ; else ; rv = rv 0
      end
      rv = rv || MRSEP
    end
  end ; else do
    cols = argc ; rows = cols ; rv = NULL
    do i = 1 for rows
      do j = 1 for cols
        if i == j then do
          value = ARG(i) ; chksum = chksum + value ; rv = rv value
          if value > 1 then ; ONE_ONLY = FALSE
        end ; else ; rv = rv 0
      end
      rv = rv || MRSEP
    end
  end
  select
    when chksum == 0 then ; type = MTYPE_ZERO
    when chksum == rows & ONE_ONLY then ; type = MTYPE_IDENTITY
    otherwise ; type = MTYPE_REGULAR
  end
  return MTAG || rows cols type || MHSEP ||,
         STRIP(CHANGESTR(MRAWSEP, rv, MRSEP))

/* -- */

isMatrix : procedure expose (globals) (matdefs)
  /*
     m
     ---
     TRUE if 'm' determined to be a matrix
     ---
     if \isMatrix(m) then ; return NaN
  */
  parse value WORD(ARG(1), 1) with marker +3 rows .
  return marker == MTAG & rows >= 1

isVector : procedure expose (globals) (matdefs)
  /*
     m
     ---
     TRUE if 'm' determined to be a vector, a 1-row matrix. Note
     that a vector is still a matrix, merely a more specialised one
     ---
     if \isVector(v) then ; return NaN
  */
  parse value WORD(ARG(1), 1) with marker +3 rows .
  return marker == MTAG & rows == 1

is2x2 : procedure expose (globals) (matdefs)
  /*
     m
     ---
     TRUE if 'm' determined to be a 2x2 matrix. Required in recursive
     matrix operations like determinant, cofactor and inverse
     ---
     if is2x2(m) then ; return mdet2x2(m)
  */
  parse value ARG(1) with (MTAG) rows cols . (MHSEP) .
  return rows == cols & rows == 2

is1x1 : procedure expose (globals) (matdefs)
  /*
     m
     ---
     TRUE if 'm' determined to be a 1x1 matrix, a single-element,
     square matrix. Required in recursive matrix operations like
     determinant, cofactor and inverse
     ---
     if is1x1(m) then ; return mdet1x1(m)
  */
  parse value ARG(1) with (MTAG) rows cols . (MHSEP) .
  return rows == cols & rows == 1

/* ----------- */

mrows : procedure expose (globals) (matdefs)
  /*
     m
     ---
     Returns number of rows matrix, 'm', possesses
     ---
     rows = mrows(m)
  */
  parse value ARG(1) with (MTAG) rows . . (MHSEP) . ; return rows

mcols : procedure expose (globals) (matdefs)
  /*
     m
     ---
     Returns number of columns matrix, 'm', possesses
     ---
     columns = mcols(m)
  */
  parse value ARG(1) with (MTAG) . cols . (MHSEP) . ; return cols

/* -- */

meql : procedure expose (globals) (matdefs)
  /*
     m1, m2
     ---
     TRUE if 'm1' and 'm2' determined to be equal, that is:
     * Structurally identical i.e. same number of rows and columns
     * Same type
     * Same contents
     ---
     if meql(m1, m2) then ; return ...
  */
  return ARG(1) == ARG(2)

/* -- */

extractMatrix : procedure expose (globals) (matdefs)
  /* 
     m
     ---
     Returns matrix data sans header 
     ---
     data = extractMatrix(m)
  */
  parse value ARG(1) with (MTAG) . . . (MHSEP) data ; return data

mrow : procedure expose (globals) (matdefs)
  /*
     m, row
     ---
     Extracts specified row number, 'row', from matrix, 'm'
     ---
     row = mrow(m, 2)
  */
  parse value ARG(1) with (MTAG) rows . . (MHSEP) data ; r = ARG(2)
  if r < 1 | r > rows then ; return NaN
  do i = 1 while data <> NULL
    parse var data row (MRSEP) data ; if i == r then ; leave
  end ; return row

mcol : procedure expose (globals) (matdefs)
  /*
     m, col
     ---
     Extracts specified column number, 'col', from matrix, 'm'
     ---
     column = mcol(m, 2)
  */
  parse value ARG(1) with (MTAG) . cols . (MHSEP) data ; c = ARG(2)
  if c < 1 | c > cols then ; return NaN
  col = NULL ; do while data <> NULL
    parse var data row (MRSEP) data ; col = col WORD(row, c)
  end ; return STRIP(col)

msubset : procedure expose (globals) (matdefs)
  /*
     m, row, col [[, xlen], ylen]
     ---
     Returns a matrix extracted from matrix, 'm', data starting from
     row number, 'row', and column number, 'col'. Entire length of
     specified items is returned unless an optional length value is
     specified for each item
     ---
     m2 = msubset(m1, 2, 3)
     m2 = msubset(m1, 2, 3, 5, 5)
     m2 = msubset(m1, 2, 3, , 5)
     m2 = msubset(m1, 2, 3, 5)
  */
  argc = ARG() ; rv = NaN
  if argc <> 3 | argc <> 5 then ; return rv
  x = ARG(2) ; y = ARG(3)
  parse value ARG(1) with (MTAG) rows cols . (MHSEP) data
  if x > rows | y > cols then ; return rv
  xlen = rows ; if ARG(4, 'E') then ; xlen = ARG(4)
  ylen = cols ; if ARG(5, 'E') then ; ylen = ARG(5)

  /* ... to be completed ... */

  return makeMatrix(STRIP(CHANGESTR(MRAWSEP, rv, MRSEP)))

mminor : procedure expose (globals) (matdefs)
  /*
     m, row, col
     ---
     Returns a matrix extracted from matrix, 'm', data consisting of
     all rows and columns except the specified row number, 'row', and
     column number, 'col'. Such a matrix is known as the 'minor' and
     is needed for computing a matrix's determinant
     ---
     minor = mminor(m, 1, 3)
  */
  argc = ARG() ; rv = NaN
  if argc <> 3 then ; return rv
  x = ARG(2) ; y = ARG(3)
  parse value ARG(1) with (MTAG) rows cols . (MHSEP) data
  if x > rows | y > cols then ; return rv

  rv = NULL ; do i = 1 while data <> NULL
    parse var data row (MRSEP) data
    if i == x then ; iterate
    do j = 1 while row <> NULL
      parse var row item row
      if j == y then ; iterate
      rv = rv item
    end ; rv = rv || MRSEP
  end
  return makeMatrix(STRIP(CHANGESTR(MRAWSEP, rv, MRSEP)))

/* -- */

mdump : procedure expose (globals) (matdefs)
  /*
     m [, width]
     ---
     Pretty prints matrix, 'm'; default width used unless specified
     ---
     call mdump m
     call mdump m, 8
  */
  parse value ARG(1) with (MTAG) . . . (MHSEP) data
  cellwidth = 4 ; if ARG(2, 'E') then ; cellwidth = ARG(2)
  do while data <> NULL
    parse var data row (MRSEP) data
    out = "|" ; do while row <> NULL
      parse var row item row ; out = out LEFT(item, cellwidth) "|"
    end
    say out
  end ; return

/* -- */

madd : procedure expose (globals) (matdefs)
  /*
     m1, m2 | n
     ---
     Returns matrix where:
     * 'n' added to each element, or
     * corresponding elements of matrices added together [each matrix
       must have the same size i.e. m1:RxC == m2:RxC]
     ---
     m3 = madd(m1, m2)
     m3 = madd(m1, 5)
  */
  m1 = ARG(1) ; m2 = ARG(2) ; rv = NaN
  if \isMatrix(m1) then ; return rv
  parse var m1 (MTAG) m1rows m1cols . (MHSEP) m1data
  if isMatrix(m2) then do
    parse var m2 (MTAG) m2rows m2cols . (MHSEP) m2data
    if m1rows <> m2rows | m1cols <> m2cols then ; return rv
    rv = NULL ; do while m1data <> NULL
      parse var m1data m1row (MRSEP) m1data
      parse var m2data m2row (MRSEP) m2data
      do while m1row <> NULL
        parse var m1row m1item m1row ; parse var m2row m2item m2row
        rv = rv (m1item + m2item)
      end ; rv = rv || MRSEP
    end
  end ; else do
    rv = NULL ; do while m1data <> NULL
      parse var m1data m1row (MRSEP) m1data
      do while m1row <> NULL
        parse var m1row m1item m1row ; rv = rv (m1item + m2)
      end ; rv = rv || MRSEP
    end
  end
  return makeMatrix(STRIP(CHANGESTR(MRAWSEP, rv, MRSEP)))

msub : procedure expose (globals) (matdefs)
  /*
     m1, m2 | n
     ---
     Returns matrix where:
     * 'n' subtracted from to each element, or
     * corresponding elements of matrices subtracted [each matrix
       must have the same size i.e. m1:RxC == m2:RxC]
     ---
     m3 = msub(m1, m2)
     m3 = msub(m1, 5)
  */
  m1 = ARG(1) ; m2 = ARG(2) ; rv = NaN
  if \isMatrix(m1) then ; return rv
  parse var m1 (MTAG) m1rows m1cols . (MHSEP) m1data
  if isMatrix(m2) then do
    parse var m2 (MTAG) m2rows m2cols . (MHSEP) m2data
    if m1rows <> m2rows | m1cols <> m2cols then ; return rv
    rv = NULL ; do while m1data <> NULL
      parse var m1data m1row (MRSEP) m1data
      parse var m2data m2row (MRSEP) m2data
      do while m1row <> NULL
        parse var m1row m1item m1row ; parse var m2row m2item m2row
        rv = rv (m1item - m2item)
      end ; rv = rv || MRSEP
    end
  end ; else do
    rv = NULL ; do while m1data <> NULL
      parse var m1data m1row (MRSEP) m1data
      do while m1row <> NULL
        parse var m1row m1item m1row ; rv = rv (m1item - m2)
      end ; rv = rv || MRSEP
    end
  end
  return makeMatrix(STRIP(CHANGESTR(MRAWSEP, rv, MRSEP)))

mmul : procedure expose (globals) (matdefs)
  /*
     m1, m2 | n
     ---
     Returns matrix where:
     * 'n' multiplied with each element, or
     * corresponding elements of matrices multiplied [matrices
       must meet condition m1:C == m2:R; m3 -> m1:Rxm2:C]
     ---
     m3 = mmul(m1, m2)
     m3 = mmul(m1, 5)
  */
  m1 = ARG(1) ; m2 = ARG(2) ; rv = NaN
  if \isMatrix(m1) then ; return rv
  parse var m1 (MTAG) m1rows m1cols . (MHSEP) m1data
  if isMatrix(m2) then do
    parse var m2 (MTAG) m2rows m2cols . (MHSEP) m2data
    if m1cols <> m2rows then ; return rv

    /* Extract matrix data, load into compound variables, 'a' and 'b' */    
    r = 1 ; c = 1 ; a.0 = m1rows ; a.0.0 = m1cols
    do while m1data <> NULL
      parse var m1data m1row (MRSEP) m1data
      do while m1row <> NULL
        parse var m1row item m1row ; a.r.c = item
        c = c + 1
      end
      r = r + 1 ; c = 1
    end
 
    r = 1 ; c = 1 ; b.0 = m2rows ; b.0.0 = m2cols
    do while m2data <> NULL
      parse var m2data m2row (MRSEP) m2data
      do while m2row <> NULL
        parse var m2row item m2row ; b.r.c = item
        c = c + 1
      end
      r = r + 1 ; c = 1
    end

    /* Perform multiplication using compound variables */
    do i = 1 to a.0                      /* m1rows */
      do j = 1 to b.0.0                  /* m2cols */
        c.i.j = 0 ; do k = 1 to b.0      /* m2rows */
          c.i.j = c.i.j + a.i.k * b.k.j 
        end 
      end 
    end 

    /* Return computed values as new matrix */
    rv = NULL ; do i = 1 to m1rows
      do j = 1 to m2cols ; rv = rv c.i.j ; end
      rv = rv || MRSEP
    end

  end ; else do
    rv = NULL ; do while m1data <> NULL
      parse var m1data m1row (MRSEP) m1data
      do while m1row <> NULL
        parse var m1row m1item m1row ; rv = rv (m1item * m2)
      end ; rv = rv || MRSEP
    end
  end  

  return makeMatrix(STRIP(CHANGESTR(MRAWSEP, rv, MRSEP)))

mdiv : procedure expose (globals) (matdefs)
  /*
     m1, m2 | n
     ---
     Returns matrix where:
     * 'n' divided into each element, or
     * corresponding elements of matrices divided [matrices
       must meet condition m1:C == m2:R, and m2 must be square;
       m3 -> m1:Rxm2:C]
     ---
     m3 = mdiv(m1, m2)
     m3 = mdiv(m1, 5)
  */
  m1 = ARG(1) ; m2 = ARG(2) ; rv = NaN
  if \isMatrix(m1) then ; return rv
  parse var m1 (MTAG) m1rows m1cols . (MHSEP) m1data
  if isMatrix(m2) then do
    parse var m2 (MTAG) m2rows m2cols . (MHSEP) m2data
    if m1cols <> m2rows | m2cols <> m2rows then ; return rv
    return mmul(m1, minverse(m2))
  end ; else do
    rv = NULL ; do while m1data <> NULL
      parse var m1data m1row (MRSEP) m1data
      do while m1row <> NULL
        parse var m1row m1item m1row ; rv = rv (m1item / m2)
      end ; rv = rv || MRSEP
    end
  end
  return makeMatrix(STRIP(CHANGESTR(MRAWSEP, rv, MRSEP)))

/* -- */

maddr : procedure expose (globals) (matdefs)
  /*
     m, n | v, row
     ---
     Returns matrix with all elements of row number, 'row',
     of matrix, 'm':
     * Having, 'n' added, or
     * corresponding elements from, 'v', added [assumes m:R == v:R]
     ---
     m2 = maddr(m1, 4, 3)
     m2 = maddr(m1, makeVector("1 2 3;"), 3)
  */
  m = ARG(1) ; v = ARG(2) ; row = ARG(3) ; rv = NaN ; isVector = FALSE
  if \isMatrix(m) then ; return rv
  parse var m (MTAG) mrows mcols . (MHSEP) mdata

  if isVector(v) then do
    parse var v (MTAG) . vcols . (MHSEP) vrow (MRSEP)
    if row > mrows | mcols <> vcols then ; return rv
    isVector = TRUE
  end

  rv = NULL ; do i = 1 while mdata <> NULL
    parse var mdata mrow (MRSEP) mdata
    if i == row then
      do while mrow <> NULL
        parse var mrow mitem mrow
        if isVector then ; parse var vrow vitem vrow ; else ; vitem = v
        rv = rv (mitem + vitem)
      end
    else
      rv = rv || mrow
    rv = rv || MRSEP
  end

  return makeMatrix(STRIP(CHANGESTR(MRAWSEP, rv, MRSEP)))

maddc : procedure expose (globals) (matdefs)
  /*
     m, n | v, col
     ---
     Returns matrix with all elements of column number, 'col',
     of matrix, 'm':
     * Having, 'n' added, or
     * corresponding elements from, 'v', added [assumes m:C == v:C]
     ---
     m2 = maddc(m1, 4, 3)
     m2 = maddc(m1, makeVector("1 2 3;"), 3)
  */
  m = ARG(1) ; v = ARG(2) ; col = ARG(3) ; rv = NaN ; isVector = FALSE
  if \isMatrix(m) then ; return rv
  parse var m (MTAG) mrows mcols . (MHSEP) mdata

  if isVector(v) then do
    parse var v (MTAG) . vcols . (MHSEP) vrow (MRSEP)
    if col > mcols | mrows <> vcols then ; return rv
    isVector = TRUE
  end

  rv = NULL ; do while mdata <> NULL
    parse var mdata mrow (MRSEP) mdata
    do j = 1 while mrow <> NULL
      parse var mrow mitem mrow
      if j == col then do
        if isVector then ; parse var vrow vitem vrow ; else ; vitem = v
        rv = rv (mitem + vitem)
      end ; else do
        rv = rv mitem
      end
    end
    rv = rv || MRSEP
  end

  return makeMatrix(STRIP(CHANGESTR(MRAWSEP, rv, MRSEP)))

mmulr : procedure expose (globals) (matdefs)
  /*
     m, n, row
     ---
     Returns matrix with all elements of row number, 'row',
     of matrix, 'm', multiplied by, 'n'
     ---
     m2 = mmulr(m1, 4, 3)
  */
  m = ARG(1) ; n = ARG(2) ; row = ARG(3) ; rv = NaN
  if \isMatrix(m) then ; return rv
  parse var m (MTAG) mrows mcols . (MHSEP) mdata
  if row > mrows then ; return rv
  rv = NULL ; do i = 1 while mdata <> NULL
    parse var mdata mrow (MRSEP) mdata
    if i == row then
      do while mrow <> NULL
        parse var mrow mitem mrow ; rv = rv (mitem * n)
      end
    else
      rv = rv mrow
    rv = rv || MRSEP
  end
  return makeMatrix(STRIP(CHANGESTR(MRAWSEP, rv, MRSEP)))

mmulc : procedure expose (globals) (matdefs)
  /*
     m, n, col
     ---
     Returns matrix with all elements of column number, 'col',
     of matrix, 'm', multiplied by, 'n'
     ---
     m2 = mmulc(m1, 4, 3)
  */
  m = ARG(1) ; n = ARG(2) ; col = ARG(3) ; rv = NaN
  if \isMatrix(m) then ; return rv
  parse var m (MTAG) mrows mcols . (MHSEP) mdata
  if col > mcols then ; return rv
  rv = NULL ; do while mdata <> NULL
    parse var mdata mrow (MRSEP) mdata
    do j = 1 while mrow <> NULL
      parse var mrow mitem mrow
      if j == col then ; rv = rv (mitem * n)
      else ; rv = rv mitem
    end
    rv = rv || MRSEP
  end
  return makeMatrix(STRIP(CHANGESTR(MRAWSEP, rv, MRSEP)))

mswapr : procedure expose (globals) (matdefs)
  /*
     m, x, y
     ---
     Returns matrix with row numbers, 'x', and 'y', of matrix, 'm',
     swapped
     ---
     m2 = mswapr(m1, 1, 3)
  */
  m = ARG(1) ; x = ARG(2) ; y = ARG(3) ; rv = NaN
  if \isMatrix(m) then ; return rv
  parse var m (MTAG) rows . . (MHSEP) data
  if x > rows | y > rows then ; return rv
  xr = mrow(m, x) ; yr = mrow(m, y)
  rv = NULL ; do i = 1 while data <> NULL
    parse var data row (MRSEP) data
    if i == x then ; rv = rv yr
    else ; if i == y then ; rv = rv xr
    else ; rv = rv row
    rv = rv || MRSEP
  end
  return makeMatrix(STRIP(CHANGESTR(MRAWSEP, rv, MRSEP)))

mswapc : procedure expose (globals) (matdefs)
  /*
     m, x, y
     ---
     Returns matrix with column numbers, 'x', and 'y', of matrix, 'm',
     swapped
     ---
     m2 = mswapc(m1, 1, 3)
  */
  m = ARG(1) ; x = ARG(2) ; y = ARG(3) ; rv = NaN
  if \isMatrix(m) then ; return rv
  parse var m (MTAG) rows cols . (MHSEP) data
  if x > cols | y > cols then ; return rv

  r = 1 ; c = 1 ; a.0 = rows ; a.0.0 = cols
  do while data <> NULL
    parse var data row (MRSEP) data
    do while row <> NULL
      parse var row item row ; a.r.c = item
      c = c + 1
    end
    r = r + 1 ; c = 1
  end

  do i = 1 to a.0
    tmp = a.i.x ; a.i.x = a.i.y ; a.i.y = tmp
  end

  rv = NULL ; do i = 1 to a.0
    do j = 1 to a.0.0 ; rv = rv a.i.j ; end
    rv = rv || MRSEP
  end

  return makeMatrix(STRIP(CHANGESTR(MRAWSEP, rv, MRSEP)))

/* -- */

mtranspose : procedure expose (globals) (matdefs)
  /*
     m
     ---
     Returns matrix consisting of the transpose of 'm' [i.e.
     corresponding row / column positions swapped]
     ---
     transpose = mtranspose(m)
  */
  m = ARG(1) ; rv = NaN
  if \isMatrix(m) then ; return rv
  parse var m (MTAG) rows cols . (MHSEP) data
  r = 1 ; c = 1 ; a.0 = rows ; a.0.0 = cols
  do while data <> NULL
    parse var data row (MRSEP) data
    do while row <> NULL
      parse var row item row ; a.r.c = item
      c = c + 1
    end
    r = r + 1 ; c = 1
  end
  rv = NULL ; do j = 1 to a.0.0
    do i = 1 to a.0 ; rv = rv a.i.j ; end
    rv = rv || MRSEP
  end
  return makeMatrix(STRIP(CHANGESTR(MRAWSEP, rv, MRSEP)))

mcofactor : procedure expose (globals) (matdefs)
  /*
     m, i, j
     ---
     Returns the cofactor of the matrix; sign determined via values
     of row and column numbers, 'i', and 'j', respectively
     ---
     cofactor = mcofactor(m, i, j)
  */
  m = ARG(1) ; i = ARG(2) ; j = ARG(3)
  if ((i + j) // 2) <> 0 then ; sign = -1 ; else ; sign = 1
  if is1x1(m) then ; return sign * mdet(m)
  return sign * mdet(mminor(m, i, j))

mdet1x1 : procedure expose (globals) (matdefs)
  /*
     m
     ---
     Returns the determinant of a 1x1 square matrix
     ---
     determinant = mdet1x1(m)
  */
  parse value ARG(1) with (MTAG) . . . (MHSEP) a (MRSEP) .
  return a

mdet2x2 : procedure expose (globals) (matdefs)
  /*
     m
     ---
     Returns the determinant of a 2x2 square matrix
     ---
     determinant = mdet2x2(m)
  */
  parse value ARG(1) with (MTAG) . . . (MHSEP) a b (MRSEP) c d (MRSEP) .
  return a * d - b * c

mdet : procedure expose (globals) (matdefs)
  /*
     m
     ---
     Returns the determinant of the square matrix
     ---
     determinant = mdet(m)
  */
  m = ARG(1)
  if is1x1(m) then ; return mdet1x1(m)
  if is2x2(m) then ; return mdet2x2(m)
  parse var m (MTAG) . cols . (MHSEP) row (MRSEP) .
  det = 0 ; do j = 1 to cols
    det = det + WORD(row, j) * mcofactor(m, 1, j)
  end ; return det

minv1x1 : procedure expose (globals) (matdefs)
  /*
     m
     ---
     Returns the inverse of the 1x1 matrix
     ---
     inverse = minv1x1(m)
  */
  parse value ARG(1) with (MTAG) . . . (MHSEP) a (MRSEP) .
  return 1 / a

minverse : procedure expose (globals) (matdefs)
  /*
     m
     ---
     Returns the inverse of the square matrix
     ---
     inverse = minverse(m)
  */
  m = ARG(1) ; if \isMatrix(m) then ; return NaN
  parse var m (MTAG) rows cols . (MHSEP) data
  if rows <> cols then ; return NaN
  if is1x1(m) then ; return makeVector(minv1x1(m))
  rv = NULL ; det = mdet(m) ; do i = 1 for rows
    do j = 1 for cols ; rv = rv (mcofactor(m, i, j) / det) ; end
    rv = rv || MRSEP
  end
  return mtranspose(makeMatrix(STRIP(CHANGESTR(MRAWSEP, rv, MRSEP))))

mtrace : procedure expose (globals) (matdefs)
  /*
     m
     ---
     Returns the trace of the square matrix [i.e. sum of the leading
     diagonal elements]
     ---
     trace = mtrace(m)
  */
  m = ARG(1) ; trace = 0
  if \isMatrix(m) then ; return NaN
  parse var m (MTAG) rows cols . (MHSEP) data
  if rows <> cols then ; return NaN
  do i = 1 while data <> NULL
    parse var data row (MRSEP) data
    do j = 1 while row <> NULL
      parse var row item row ; if i == j then ; trace = trace + item
    end
  end
  return trace

/* @@PLEAC@@_2.15 */
/* ------------------------------------------------------------------ */
/* REXX offers no complex number-handling BIF's. However, there are   */
/* native-REXX implementations available from:                        */
/*                                                                    */
/*     http://www.geocities.com/zabrodskyvlada/aat/a_contents.html    */
/*                                                                    */
/* just as there are implementations of many other classic algorithms.*/
/*                                                                    */
/* The code below, however, is not adapted from the examples at this  */
/* site, but is instead inspired by a Scheme implementation in the    */
/* very well known publication, 'Structure and Interpretation of Prog-*/
/* rams' by Abelson and Sussman. See:                                 */
/*                                                                    */
/*     http://mitpress.mit.edu/sicp/full-text/sicp/book/node43.html   */
/* ------------------------------------------------------------------ */

/* Using 'rexxMath' Library Routines */

/* Load [rexxMath] math functions from external library */
call rxFuncAdd 'mathLoadFuncs', 'rexxMath', 'mathLoadFuncs'
call mathLoadFuncs

/* ----------- */

a = makeComplex(3, 5) ; b = makeComplex(2, -2)

c = cmul(a, b)

say "c =" asComplex(c)

/* ----------- */

c = cmul(makeComplex(3, 5), makeComplex(2, -2))

say "c =" asComplex(c)

/* ----------- */

d = makeComplex(3, 4)

say "d =" asComplex(d)
say "sqrt(d) =" asComplex(csqrt(d))

/* ----------- */

say "Rectangualar Notation:" asComplex(csqrt(makeComplex(3, 4)))

say "Polar Notation:" asPolar(csqrt(makeComplex(3, 4)))

/* ----------- */

/* Unload math functions */
call mathDropFuncs

exit 0

/* ----------------------------- */

makeComplex : procedure
  return "<C> " ARG(1) " " ARG(2)

makeFromPolar : procedure
  r = ARG(1) ; a = ARG(2)
  return makeComplex(r * Cos(a), r * Sin(a))

real : procedure
  parse value ARG(1) with "<C>" real . ; return real

imag : procedure
  parse value ARG(1) with "<C>" . imag . ; return imag

magnitude : procedure
  parse value ARG(1) with "<C>" real imag .
  return Sqrt(real * real + imag * imag)

angle : procedure
  parse value ARG(1) with "<C>" real imag .
  return ATan(imag, real)

isNaN : procedure
  return ARG(1) == "NaN"

isComplex : procedure
  return LEFT(ARG(1), 3) == "<C>"

asComplex : procedure
  z = ARG(1) ; if \isComplex(z) then ; return "NaN"
  else ; do
    parse var z "<C>" real imag .
    dec = 3 ; if ARG(2, E) then ; dec = ARG(2)
    sign = "+" ; if imag < 0 then ; sign = "-"
    return FORMAT(real,, dec) sign FORMAT(ABS(imag),, dec) || "i"
  end 

asPolar : procedure
  z = ARG(1) ; if \isComplex(z) then ; return "NaN"
  else ; do
    parse var z "<C>" real imag .
    dec = 3 ; if ARG(2, E) then ; dec = ARG(2)
    return "(" || FORMAT(magnitude(z),, dec) || ",",
           FORMAT(angle(z),, dec) || ")"
  end 

/* ----------- */

cadd : procedure
  z1 = ARG(1) ; z2 = ARG(2)
  if \isComplex(z1) | \isComplex(z1) then ; return "NaN"
  rz1 = real(z1) ; rz2 = real(z2); iz1 = imag(z1) ; iz2 = imag(z2)
  return makeComplex((rz1 + rz2), (iz1 + iz2))

csub : procedure
  z1 = ARG(1) ; z2 = ARG(2)
  if \isComplex(z1) | \isComplex(z1) then ; return "NaN"
  rz1 = real(z1) ; rz2 = real(z2); iz1 = imag(z1) ; iz2 = imag(z2)
  return makeComplex((rz1 - rz2), (iz1 - iz2))

cmul : procedure
  z1 = ARG(1) ; z2 = ARG(2)
  if \isComplex(z1) | \isComplex(z1) then ; return "NaN"
  mz1 = magnitude(z1) ; mz2 = magnitude(z2) ; az1 = angle(z1)
  az2 = angle(z2)
  return makeComplex((mz1 * mz2), (az1 + az2))

cdiv : procedure
  z1 = ARG(1) ; z2 = ARG(2)
  if \isComplex(z1) | \isComplex(z1) then ; return "NaN"
  mz1 = magnitude(z1) ; mz2 = magnitude(z2) ; az1 = angle(z1)
  az2 = angle(z2)
  return makeComplex((mz1 / mz2), (az1 - az2))

csqrt : procedure
  z = ARG(1) ; if \isComplex(z) then ; return "NaN"
  r = magnitude(z) ; a = angle(z)
  u = makeComplex(Sqrt(r) * Cos(a / 2.0), Sqrt(r) * Sin(a / 2.0))
  t = makeComplex(-real(u), -imag(u))
  if \(angle(u) < angle(t)) then ; u = t
  return u

/* @@PLEAC@@_2.16 */
/* ------------------------------------------------------------------ */
/* Whilst binary, hexadecimal, decimal interconversion is quite well  */
/* supported in REXX, octal support is non-existent. This is because  */
/* of REXX's mainframe heritage: octal is simply not used on these    */
/* platforms.                                                         */
/*                                                                    */
/* It is, however, quite easy to implement suitable custom functions  */
/* as has been done here.                                             */
/* ------------------------------------------------------------------ */

  hexadecimal = "2A" ; octal = "10"

  number = X2D(hexadecimal)
  number = O2D(octal)

  hexadecimal = D2X(number)
  octal = D2O(number)

/* ----------------------------- */

  /*
     Assumes following input formats:

       decimal - plain digits
       octal - leading '0' character
       hexadecimal - leading '0x' | '0X' character sequence

     e.g.

       14 -> 016 -> 0xE
  */

  call CHAROUT , "Gimme a number in decimal, octal, or hex: "

  parse value LINEIN() with "0x" hex =1 "0" oct =1 dec

  select
    when hex \= NULL then ; number = X2D(hex)
    when oct \= NULL then ; number = O2D(oct)
    when dec \= NULL then ; number = dec
  end

  say number "d" D2X(number) "h" D2O(number) "o"

  exit 0

/* ----------- */

D2O : procedure expose (globals)
  parse arg d, o
  do until d = 0 ; r = d // 8 ; d = d % 8 ; o = r || o ; end
  return o

O2D : procedure expose (globals)
  parse value ARG(1) LENGTH(ARG(1)) 0 with ov sp dv
  do i = 1 for sp
    parse var ov =(i) oi +1
    if oi == "8" | oi == "9" then ; return NULL
    parse value (dv + ((8 ** (sp - i)) * oi)) with dv
  end
  return dv

/* @@PLEAC@@_2.17 */
/* ------------------------------------------------------------------ */
/* REXX-idiomatic approach to this task is via 'do' loop and string   */
/* manipulation BIF since it is cross-platform and guarantees the best*/
/* performance. However, a recursive solution is easily implementable */
/* ------------------------------------------------------------------ */

/* REXX-idiomatic 'do' loop and BIF Example */

commified = commify("12345678") ; say commified

exit 0

/* ----------- */

commify : procedure expose (globals)
  s = ARG(1) ; l = LENGTH(s) - 3
  do i = l by -3 while i > 0 ; s = INSERT(",", s, i) ; end
  return s

/* ----------------------------- */

/* Recursive Implementation */

commified = commify("12345678") ; say commified

exit 0

/* ----------- */

commify : procedure expose (globals)
  return STRIP(commify_(REVERSE(ARG(1))), 'T', ",")

commify_ : procedure expose (globals)
  parse value ARG(1) with car +3 cdr
  if car == NULL then ; return NULL
  return commify_(cdr) || REVERSE(car) || ","

/* @@PLEAC@@_2.18 */
/* ------------------------------------------------------------------ */
/* REXX-idiomatic approach to this task is via 'do' loop and the PARSE*/
/* instruction.                                                       */
/* ------------------------------------------------------------------ */

duration = 1
say "It took" duration pluralise(duration, "hour")
say duration pluralise(duration, "hour"),
    pluralise(duration, "", "is", "are"),
    "enough"

duration = 5
say "It took" duration pluralise(duration, "hour")
say duration pluralise(duration, "hour"),
    pluralise(duration, "", "is", "are"),
   "enough"

exit 0

/* ----------- */

pluralise : procedure
  value = ARG(1) ; root = ARG(2)
  singular = "" ; if ARG(3, 'E') then ; singular = ARG(3)
  plural = "s" ; if ARG(4, 'E') then ; plural = ARG(4)
  if value == 1 then ; return root || singular
  return root || plural

/* ----------------------------- */

list = "mess index leaf puppy"

do while list <> "" 
  parse var list word list
  say LEFT(word, 6) "->" plural(word)
end

exit 0

/* ----------- */

plural : procedure
  endings = "ss:sses ph:phes sh:shes ch:ches ey:eys ix:ices",
            "ff:ffs z:zes f:ves y:ies s:ses x:xes"

  singular = ARG(1) ; plural = singular ; do while endings <> NULL
    parse var endings key ":" value endings

    /* ===
       Both approaches below work. First one makes exclusive use of
       string manipulation BIF's, while the second one uses the PARSE
       instruction to split a string, and is probably faster

    /* 1 */
    if RIGHT(singular, LENGTH(key)) == key then do
      plural = LEFT(singular, LENGTH(singular) - LENGTH(key)) || value
      leave
    end

    /* 2 */
    pos = LENGTH(singular) - LENGTH(key)
    parse var singular car +(pos) cdr
    if cdr == key then do ; plural = car || value ; leave ; end

    === */

    pos = LENGTH(singular) - LENGTH(key)
    parse var singular car +(pos) cdr
    if cdr == key then do ; plural = car || value ; leave ; end

  end

  return plural

/* @@PLEAC@@_3.0 */
/* ------------------------------------------------------------------ */
/* Unlike Perl, REXX has no predefined, global date/time variables    */
/* [e.g. '$year', '$mday' etc]. Instead, native date/time support is  */
/* offered by two built-in functions [BIFs]:                          */
/*                                                                    */
/* * DATE([option_out [, date [, option_in]]])                        */
/* * TIME([option_out [, time [, option_in]]])                        */
/*                                                                    */
/* These BIFs operate in two modes:                                   */
/*                                                                    */
/* * Generate a date/time string formatted according to 'option_out'  */
/*   using the current date/time                                      */
/*                                                                    */
/* * Accept a date/time string in format specified by 'option_in', and*/
/*   use it to generate a string as specified by 'option_out'         */
/*                                                                    */
/* Typical REXX code will see either direct use of these BIF's along  */
/* with parsing / formatting code, or more likely, used as part of    */
/* custom date/time routines. It is this latter approach that will be */
/* used here as most of the examples use routines from the REXXToolkit*/
/* Library [see Appendix for details].                                */
/*                                                                    */
/* It is worth mentioning that REXX, unlike Perl, and other languages,*/
/* sports no 'date' or 'time' type / structure / object, and that such*/
/* values are always represented as strings. It is, however, quite a  */
/* simple matter to implement functionally equivalent entities. This  */
/* has been done: a 'super'-string, the Date-Time-String [DTS], is    */
/* used in many of the examples. While useful in itself the motivation*/
/* for implementing it has been to show how type / structure / object */
/* can be implemented procedurally using non-mutable strings.         */
/* ------------------------------------------------------------------ */

/* @@PLEAC@@_3.1 */
/* ------------------------------------------------------------------ */
/* The usual way of obtaining the current date is to invoke the DATE()*/
/* BIF to generate a recognised date format, parse, then manipulate,  */
/* the resulting string as required.                                  */
/*                                                                    */
/* However since additional string manipulation of the resulting item */
/* is usually required, it is usual to see custom native REXX routines*/
/* implemented for such tasks. The examples make use of such as set of*/
/* routines [REXXToolkit Library - see appendix for details]          */
/* ------------------------------------------------------------------ */

/* Generate, then parse, date string in 'standard' format: YYYYMMDD */
parse value DATE('S') with year +4 month +2 day

/* ----------------------------- */

/* Formatting via basic string manipulation */
SEP = SPACE
say "The current date is" year || SEP || month || SEP || day

SEP = DATESEP
say "The current date is" year || SEP || month || SEP || day

/* ----------------------------- */

/* Using 'makeYMD' helper function */
say "The current date is" makeYMD(SPACE, year, month, day)
say "The current date is" makeYMD(SPACE)

say "The current date is" makeYMD(DATESEP, year, month, day)
say "The current date is" makeYMD(DATESEP)
say "The current date is" makeYMD()

/* Optional date validity check */
current = makeYMD()
if current == NULL then ; current = "*invalid date*"
say "The current date is" current

/* Alternative date validity check */
current = makeYMD()
if \isYMD(current) then ; current = "*invalid date*"
say "The current date is" current

/* ----------------------------- */

/* Using 'localtime' and 'YMDHMS...' helper functions */
say "The current date is" YMDHMS2YMD(EPS2YMDHMS(localtime()), SPACE)
say "The current date is" YMDHMS2YMD(EPS2YMDHMS(localtime()))

/* ----------------------------- */

/* Using 'strftime' helper function */
say "The current date is" strftime("+%Y %m %d")
say "The current date is" strftime("+%Y-%m-%d")

/* @@PLEAC@@_3.2 */
/* ------------------------------------------------------------------ */
/* UNIX-derived languages Perl and C store date/time values as 32 bit */
/* entities - epoch seconds [seconds since Jan 1, 1970]. This provides*/
/* for a simple, efficient, easily manipuable, and readily convertable*/
/* format [i.e. minimal storage use, easy to perform date arithmetic].*/
/*                                                                    */
/* Since all REXX values are strings, and all arithmetic is string-   */
/* based, there are no efficiency benefits in doing the same in REXX. */
/* However, since epoch second use is so widespread, the 'DATE' BIF   */
/* supports it via the 'T' option, thus allowing for some of the same */
/* Perl / C techniques to be mimiced in REXX.                         */
/* ------------------------------------------------------------------ */

/* Get current date/time in Epoch Seconds */

/* Local timezone */
say "Epoch seconds:" DATE('T')          /* REXX BIF */

say "Epoch seconds:" localtime()        /* Custom routines */
say "Epoch seconds:" strftime("+%s")

/* UTC */
say "Epoch seconds:" gmtime()

/* ----------------------------- */

/* Convert YMDHMS-formatted current date/time to Epoch Seconds */

ymdhms = makeYMDHMS(makeYMD(), makeHMS())

/* Convert to Epoch Seconds [alternative: localtime(ymdhms)] */
eps = YMDHMS2EPS(ymdhms)

/* ----------------------------- */

/* Convert YMDHMS-formatted date/time to Epoch Seconds */

/* Literal string in YMDHMS format */
ymdhms = "2004-04-17 13:03:55"  

/* Alternatively, make YMDHMS-formatted date/time from components */
y = 2004 ; mth = 4 ; d = 17 ; h = 13 ; m = 3 ; s = 55
ymdhms = makeYMDHMS(makeYMD(DATESEP, y, mth, d),,
         makeHMS(TIMESEP, h, m, s))

/* Convert to Epoch Seconds [alternative: localtime(ymdhms)] */
eps = YMDHMS2EPS(ymdhms)

/* @@PLEAC@@_3.3 */
/* ------------------------------------------------------------------ */
/* See comments in previous section header                            */
/* ------------------------------------------------------------------ */

/* Convert Epoch Seconds to date/time [YMDHMS-format] */

eps = localtime()               /* or: gmtime(), or DATE('T') */

/* Convert to YMDHMS */
ymdhms = EPS2YMDHMS(eps)

/* ----------------------------- */

/* Parse YMDHMS into components, format and print */
parse var ymdhms,
  year (DATESEP) month (DATESEP) day,
  hour (TIMESEP) minute (TIMESEP) second

fmtdate = hour || TIMESEP || minute || TIMESEP || second || "-" ||,
          year || "/" || month || "/" || day
say "Dateline:" fmtdate

/* ----------------------------- */

/* Use helpers to suitably format date for printing */
fmtdate = YMDHMS2HMS(ymdhms, TIMESEP) || "-" || YMDHMS2YMD(ymdhms, "/")
say "Dateline:" fmtdate

/* @@PLEAC@@_3.4 */
/* ------------------------------------------------------------------ */
/* Date/time arithmetic may be performed:                             */
/*                                                                    */
/* * Directly on date/time components                                 */
/* * Converting to a base value, performing arithmetic, then back to  */
/*   date/time format                                                 */
/*                                                                    */
/* REXX supports base value conversion approach via 'DATE' and 'TIME' */
/* BIFs, and does so in two ways:                                     */
/*                                                                    */
/* * Base Date Method                                                 */
/* * UNIX-derived 'epoch seconds' Method                              */
/*                                                                    */
/* The latter method is widely used so will not be described, but the */
/* examples well illustrate its usage. The 'base date' method is day  */
/* based [days since 1 Jan 0001 AD], and quite simple to use if date  */
/* arithmetic is day-based. If finer granularity is needed then both  */
/* the 'DATE' and 'TIME' BIF's must be used making this method less   */
/* convenient to use. Despite this, it is the method of choice if     */
/* cross-platform portability is a concern as not all REXX interpreter*/
/* are guaranteed to support the 'epoch seconds' method.              */
/* ------------------------------------------------------------------ */

when = now + difference
then = now - difference

/* ----------------------------- */

/* Helper function use: 'dateOffset', and 'dateInterval' */ 

now = YMDHMS2EPS(makeYMDHMS(makeYMD(DATESEP, 2003, 8, 6), makeHMS()))

diff1 = dateOffset("day=1") ; diff2 = dateOffset("weeks=-2")

say "One day in the future is:" EPS2YMDHMS(now + diff1)

say "Two weeks in the past is:" EPS2YMDHMS(now + diff2)

d1 = YMDHMS2EPS(makeYMDHMS(makeYMD(DATESEP, 2003, 8, 6),,
       makeHMS(TIMESEP))) 
d2 = YMDHMS2EPS(makeYMDHMS(makeYMD(DATESEP, 2000, 8, 6),,
       makeHMS(TIMESEP)))

interval = d1 - d2
say "Interval - weeks:" dateInterval("weeks", interval)
say "Interval - days:" dateInterval("days", interval)
say "Interval - hours:" dateInterval("hours", interval)
say "Interval - minutes:" dateInterval("minutes", interval)
say "Interval - seconds:" dateInterval("seconds", interval)

/* ----------------------------- */

/* Epoch second-based arithmetic */

/* 18th January, 1973 3:45:50 am */
birthtime = YMDHMS2EPS(makeYMD(DATESEP, 1973, 1, 18),
                       makeHMS(TIMESEP, 3, 45, 50))

interval = 5 + ,                      /* 5 seconds */
           17 * 60 + ,                /* 17 minutes */
           2 * 60 * 60 + ,            /* 2 hours */
           55 * 60 * 60 * 24          /* 55 days */

then = birthtime + interval

say "Then is:" YMDHMS2UNIX(EPS2YMDHMS(then))

/* ----------- */

/* REXX 'Base Date'-based arithmetic */

/* 18th January, 1973 3:45:50 am */
bday = DATE('B', "19730118", 'S') ; btime = TIME('S', "03:45:50", 'N')

interval_days = 55 ; interval_secs = 5 + 17 * 60 + 2 * 3600
then_days = bday + interval_days ; then_secs = btime + interval_secs

parse value DATE('S', then_days, 'B'),
            TIME('N', then_secs, 'S'),
            LEFT(DATE('W', then_days, 'B'), 3),
            LEFT(DATE('M', then_days, 'B'), 3) with,
            year +4 month +2 day +2 hms downame monthname

say "Then is:" downame monthname day hms year

/* ----------------------------- */

/* 18th January, 1973 3:45:50 am */
birth = YMDHMS2EPS(makeYMD(DATESEP, 1973, 1, 18),
                   makeHMS(TIMESEP, 3, 45, 50))

say "Nat was 55 days old on:",
  YMD2US(YMDHMS2YMD(EPS2YMDHMS(birth + dateOffset("days=55"))),," / ")

/* ----------- */

/* 18th January, 1973 3:45:50 am */
bday = DATE('B', "19730118", 'S')

parse value DATE('S', bday + 55, 'B') with year +4 month +2 day +2

say "Nat was 55 days old on:" month "/" day "/" year

/* @@PLEAC@@_3.5 */
/* ------------------------------------------------------------------ */
/* See comments in previous section header                            */
/* ------------------------------------------------------------------ */

when = now + difference
then = now - difference

/* ----------------------------- */

bree = YMDHMS2EPS(makeYMD(DATESEP, 1981, 6, 16),
                  makeHMS(TIMESEP, 4, 35, 25))

nat = YMDHMS2EPS(makeYMD(DATESEP, 1973, 1, 18),
                 makeHMS(TIMESEP, 3, 45, 50))

diff = bree - nat

say "There were" dateInterval("minutes", diff) "minutes",
    "between Nat and Bree"

/* ----------- */

say "There were" dateInterval("weeks", diff) "weeks,",
    diff // dateOffset("weeks=1") % dateOffset("days=1") || ", days,",
    S2HMS(diff // dateOffset("days=1")) "between Nat and Bree"

/* ----------- */

say "There were" dateInterval("days", diff) "days",
    "between Nat and Bree"

/* @@PLEAC@@_3.6 */
/* ------------------------------------------------------------------ */
/* The REXX-idiomatic approach to this task is to perform arithmetic  */
/* using the value obtained from the relevant 'DATE' BIF call.        */
/* However, as with many other date/time tasks, packaging them as     */
/* custom routines allows them to be more reliably, and conveniently  */
/* performed.                                                         */
/* ------------------------------------------------------------------ */

/* REXX-idiomatic approach using 'DATE' BIF */

day_of_week = DATE('B') // 7 + 1
day_of_week = DATE('B', YMDHMS2EPS(ymdhms), 'T') // 7 + 1

day_of_year = DATE('D')
day_of_year = DATE('D', YMDHMS2EPS(ymdhms), 'T')

week_of_year = day_of_year % 7 + 1

/* ----------------------------- */

/*
   DTS Format ['extractDTS' / 'updateDTS' indices below]:

       yyyy-mm-dd hh:mm:ss +HHMM DOWNAME DOW DOY WOY EPS
       1    2  3  4  5  6  7     8       9   10  11  12
*/

dts = makeDTS(makeYMD(), makeHMS())

day_of_week = extractDTS(dts, 9)
day_of_year = extractDTS(dts, 10)
week_of_year = extractDTS(dts, 11)

/* ----------------------------- */

day_of_week = strftime("+%w")
day_of_year = strftime("+%j")
week_of_year = strftime("+%W")

/* ----------- */

day_of_week = getDOW()
day_of_year = getDOY()
week_of_year = getWOY()

/* ----------------------------- */

ymdhms = makeYMDHMS(makeYMD(DATESEP, 1981, 6, 16), makeHMS(TIMESEP))
say YMDHMS2YMD(ymdhms, "/") "was a" getDOWName(ymdhms)
say "in week" getWOY(ymdhms) || "."

/* ----------- */

dts = makeDTS(makeYMD(DATESEP, 1981, 6, 16), makeHMS(TIMESEP))

say YMDHMS2YMD(DTS2YMDHMS(dts), "/") "was a" extractDTS(dts, 8)
say "in week" extractDTS(dts, 11) || "."

say YMDHMS2YMD(DTS2YMDHMS(dts), "/") "was a" getDOWName(dts)
say "in week" getWOY(dts) || "."

/* @@PLEAC@@_3.7 */
/* ------------------------------------------------------------------ */
/* REXX date/time validation can be performed a few ways:             */
/*                                                                    */
/* * Make 'DATE' / 'TIME' BIF calls, and check whether a SYNTAX       */
/*   condition is generated [indicating a 'bad' date/time value]      */
/* * Parse date/time values, and check individual component values    */
/* * Regular expressions [via 'RxRe' external library]                */
/*                                                                    */
/* The first approach is easy to implement, but probably best used    */
/* to create custom validation routines rather than in inline code.   */
/* This is because condition-checking requires the use of SIGNAL, and */
/* jumping to labels - such code is best quarantined within a routine */
/* body.                                                              */
/*                                                                    */
/* The second approach sees the PARSE instruction used to break up    */
/* date/time strings into components which are then conditionally     */
/* tested. In short, very typical procedural code, of which several   */
/* examples appear below. Of particular note is an implementation of  */
/* the C-derived 'strptime' function, a very convenient validation    */
/* routine.                                                           */
/*                                                                    */
/* The third approach is language-neutral, and is available in most   */
/* modern languages. Not all REXX interpreters can be expected to     */
/* offer it since it depends on external library availability         */
/* ------------------------------------------------------------------ */

/* Custom Validation Routine  [REXXToolkit] Examples */

date = "1998-06-03"
if \isYMD(date) then ; say "*invalid date*"

time = "22:19:34"
if \isHMS(date) then ; say "*invalid time*"

/* ----------- */

parse var date yyyy (DATESEP) mm (DATESEP) dd
if \acceptableYMDValues(yyyy, mm, dd) then ; say "*invalid date*"

parse var time h (TIMESEP) m (TIMEEP) s
if \acceptableHMSValues(h, m, s) then ; say "*invalid time*"

/* ----------------------------- */

/* 'strptime' Examples */

/* *** incomplete *** */

/* ----------------------------- */

/* Regex-based Examples */

/* *** incomplete *** */

/* @@PLEAC@@_3.8 */
/* ------------------------------------------------------------------ */
/* Formatting date/time values for printing or other output purposes  */
/* sees 'raw' components [e.g. year, month, etc] variously converted, */
/* and combined to meet requirements. Since such components are just  */
/* strings in REXX, it amounts to no more than a string manipulation  */
/* exercise. As such, no specialised date formatting facilities are   */
/* offered - it is left to the programmer to perform as they see fit. */
/* A few things are worth mentioning:                                 */
/*                                                                    */
/* * The 'DATE' and 'TIME' BIF's allow some inter-format conversions  */
/*   but are too limited to be of much practical value on their own - */
/*   additional string manipulation is nearly always required         */
/*                                                                    */
/* * The more common date formatting, conversion and validation tasks */
/*   are packaged as native REXX 'helper' routines in the REXXToolkit */
/*                                                                    */
/* * The UNIX-derived [now POSIX standard] 'strftime' facility and    */
/*   accompanying mini 'date formatting language' have proved to be so*/
/*   versatile that a native REXX implementation is offered in the    */
/*   REXXToolkit's set of date/time routines                          */
/* ------------------------------------------------------------------ */

/* 'DATE' and 'TIME' examples */

ymd = "20050825" ; hms = "11:08:04"

downame = DATE('W', ymd, 'S') ; monthname = DATE('M', ymd, 'S')
parse var ymd year +4 month +2 day

/* Standard UNIX Format: Thu Aug 25 11:08:04 2005 */
unix = LEFT(downame, 3) LEFT(monthname, 3) day hms year

/* As per Perl example */
say "'DATE' gives:" downame month || "/" || day || "/" || RIGHT(year, 2)

/* ----------------------------- */

/* 'strftime' examples */

ymdhms = "2005-08-25 11:08:04"

/* Standard UNIX Format: Thu Aug 25 11:08:04 2005 */
unix = strftime("+%c", ymdhms)
unix = strftime("+%a %b %d %T %Y", ymdhms)

/* As per Perl example */
say "strftime gives:" strftime("+%A %D", ymdhms)

/* ----------------------------- */

/* Miscellaneous REXXToolkit routines examples */

/* Year-Month-Day Formats */
ymd = makeYMD()                       /* 2005-08-25 */
say ymd

say makeYMD("/")                      /* 2005/08/25 */
say makeYMD(SPACE)                    /* 2005 08 25 */
say makeYMD(NULL)                     /* 20050825 */

/* Other Year-Month-Day Formats */
say YMD2US(ymd)                       /* 08/25/2005 */
say YMD2UK(ymd)                       /* 25/08/2005 */

say YMD2ISOWD(ymd)                    /* 2005-W34-4 */
say YMD2ISODDD(ymd)                   /* 2005-237 */

/* ----------- */

/* Hour-Minute-Second Formats */
say makeHMS(TIMESEP)                  /* 00:00:00 */

say makeHMS()                         /* 11:08:04 */
say makeHMS(".", 11, 8, 4)            /* 11.08.04 */
say makeHMS(SPACE, 11, 8, 4)          /* 11 08 04 */
say makeHMS(NULL, 11, 8, 4)           /* 110804 */

/* ----------- */

/* YMDHMS Examples */

/* 2005-08-25 11:08:04 */
ymdhms = EPS2YMDHMS(localtime())
ymdhms = makeYMDHMS(makeYMD(), makeHMS())

/* Standard ISO Format: 2005-08-25T11:08:04 */
iso = YMDHMS2ISO(ymdhms)

iso = CHANGESTR(SPACE, ymdhms, ISOSEP)

/* Standard UNIX Format: Thu Aug 25 11:08:04 2005 */
unix = YMDHMS2UNIX(ymdhms)

unix = LEFT(getDOWName(ymdhms), 3) LEFT(getMonthName(ymdhms), 3),
       getDay(ymdhms) YMDHMS2HMS(ymdhms) getYear(ymdhms)

/* As per Perl example */
say "YMDHMS gives:" getDOWName(ymdhms) YMD2US(YMDHMS2YMD(ymdhms), 'S')

/* ----------- */

/* Date-Time-Structure [DTS] Examples */

/* 2005-08-25 11:08:04 +1000 August Thursday 4 237 34 1124932084 */
dts = makeDTS(makeYMD(), makeHMS())

/* Standard UNIX Format: Thu Aug 25 11:08:04 2005 */
unix = LEFT(extractDTS(dts, 9), 3) LEFT(extractDTS(dts, 8), 3),
       extractDTS(dts, 3) YMDHMS2HMS(DTS2YMDHMS(dts)) extractDTS(dts, 1)

unix = LEFT(getDOWName(dts), 3) LEFT(getMonthName(dts), 3),
       getDay(dts) YMDHMS2HMS(DTS2YMDHMS(dts)) getYear(dts)

/* As per Perl example */
say "DTS gives:" extractDTS(dts, 9),
                 YMD2US(YMDHMS2YMD(DTS2YMDHMS(dts)), 'S')

/* @@PLEAC@@_3.9 */
/* ------------------------------------------------------------------ */
/* Timing in REXX is usually performed with the 'TIME' BIF, and it may*/
/* take three forms:                                                  */
/*                                                                    */
/* * High resolution [sub-second-based] timing via, TIME('L')         */
/* * Low resolution [second-based] timing via, TIME('T')              */
/* * Stop watch [second-based] timing via, TIME('R') and TIME('E')    */
/*                                                                    */
/* The precision of high resolution timing is platform-specific, so   */
/* caution is needed in interpreting the microsecond-based value      */
/* returned from TIME('L') calls. On UNIX / Win32 desktop systems it  */
/* is probably safest to assume that values are in the millisecond    */
/* range, and no more accurate than about +/- 20 ms.                  */
/*                                                                    */
/* Low resolution timing via TIME('T') [i.e. Epoch second] calls is   */
/* easily performed, but not all REXX interpreters may offer this     */
/* option.                                                            */
/*                                                                    */
/* Stop watch timing is platform-independant, easy to use, hence quite*/
/* widely used; it would qualifiy as a REXX-idiomatic practice        */
/* ------------------------------------------------------------------ */

/* High resolution timer [i.e. microsecond (us) granularity] */

/* Start time - time of day ['long' format to us. resolution] */
t1 = TIME('L')

/* Perform timed operation(s) here */

/* Stop Time */
t2 = TIME('L') 

/* Extract us. values, and compute elapsed time in ms.*/
parse var t1 . "." t1us ; parse var t2 . "." t2us
elapsed_ms = (t2us - t1us) / 1000

/*
   For timings likely to exceed 1 second then other time components
   need to be extracted. The helper function, 'LHMS2S' computes time
   in fractional seconds [to ms. precision]
*/

elapsed_s = LHMS2S(t2) - LHMS2S(t1)

/* ----------------------------- */

/* Low resolution timer [i.e. second (s) granularity] */

/* Start time - time of day [Epoch seconds] */
t1 = TIME('T')

/* Perform timed operation(s) here */

/* Stop Time */
t2 = TIME('T') 

/* Compute elapsed time in seconds */
elapsed = t2 - t1

/* ----------- */

/* Low resolution 'stopwatch' timer [i.e. second (s) granularity] */

/* Reset timer */
call TIME 'R'

/* Perform timed operation(s) here */

/* Seconds since last timer reset */
elapsed = TIME('E')

/* ----------------------------- */

/* Load general-purpose functions from external library */
call rxFuncAdd 'sysLoadFuncs', 'rexxUtil', 'sysLoadFuncs'
call sysLoadFuncs

/* Extract before and after times for operation */
before = TIME('L')
call CHAROUT , "Press any key ..." ; call sysGetKey
after = TIME('L') 

/* Compute elapsed time in fractional seconds [to ms. precision] */
elapsed = LHMS2S(after) - LHMS2S(before)

say "You took" elapsed "seconds"

/* Unload general-purpose functions */
call sysDropFuncs

exit 0

/* ----------------------------- */

/* Load general-purpose functions from external library */
call rxFuncAdd 'sysLoadFuncs', 'rexxUtil', 'sysLoadFuncs'
call sysLoadFuncs

stem.0 = 500 ; repetitions = 100 ; total_time = 0 

do repetitions
  /* Load array */
  do i = 1 for stem.0
    stem.i = RANDOM()
  end

  /* Time sort operation */
  start = TIME('L')
  call sysStemSort 'stem.'
  stop = TIME('L')

  /* Extract timings and accumulate */  

  /*
     Given the sub-second duration of the operation, the following
     approach could be used:

       parse var start . "." start ; parse var stop . "." stop
       elapsed = (stop - start) / 1000000

     However, for maximum safety, best use 'LHMS2S'
  */

  elapsed = LHMS2S(stop) - LHMS2S(start)

  total_time = total_time + elapsed
end

say "On average, sorting" stem.0 "random numbers takes",
    total_time / repetitions "seconds"

drop stem.

/* Unload general-purpose functions */
call sysDropFuncs

exit 0

/* @@PLEAC@@_3.10 */
/* ------------------------------------------------------------------ */
/* Given the platform-specific nature of this task, REXX offers no    */
/* in-built support for it aside, of course, from allowing a 'busy    */
/* wait' loop to be implemented, an approach best avoided if possible.*/
/*                                                                    */
/* As is typical for such tasks, the needed functionality is obtained */
/* either from a third party library, or by invoking a system command */
/* utility. Examples of each follow.                                  */
/* ------------------------------------------------------------------ */

/* 'busy waiting' using built-in 'TIME' function - *AVOID* */

stoptime = TIME('S') + 3.5            /* 3.5 second pause */

do while TIME('S') < stoptime
  /* Do nothing, except burn CPU cycles :) ! */
  nop
end

/* ----------------------------- */

/* Invoking 'sysSleep' function: fine granularity, no CPU wastage */

/* Load general-purpose functions from external library */
call rxFuncAdd 'sysLoadFuncs', 'rexxUtil', 'sysLoadFuncs'
call sysLoadFuncs

call sysSleep 3.5                    /* 3.5 second pause */
call sysSleep 0.35                   /* 0.35 second pause */
call sysSleep 0.035                  /* 0.035 second pause */

/* Unload general-purpose functions */
call sysDropFuncs

exit 0

/* ----------------------------- */

/* Command: UNIX / Win32 'sleep' utility, granularity is seconds */

cmd = "sleep" ; seconds = 3
address SYSTEM cmd seconds with OUTPUT STREAM 'NUL:' ERROR STREAM 'NUL:'

/* @@PLEAC@@_4.0 */
/* ------------------------------------------------------------------ */
/* REXX is perhaps an unusual language in that it does not implement  */
/* either C-style structures or C-style arrays. Instead, it implements*/
/* what are called 'compound variables' which, under the covers, are a*/
/* form of associative array [or 'hash', to use the Perl treminology].*/
/* Compound variable usage will be further discussed in Chapter 5 in  */
/* the context of Perl 'hashes'.                                      */
/*                                                                    */
/* Compound variable usage aside, array-like functionality may be had */
/* via:                                                               */
/*                                                                    */
/* * Third party libraries ['rxHash' library illustrated here] which  */
/*   merely involves manipulating array-like objects using relevant   */
/*   library subroutines. Any mention of 'arrays' in this chapter is  */
/*   to be understood as referring to entities created using this     */
/*   library, and it should be appreciated that such code is not truly*/
/*   portable, but specific to platforms on which this library is     */
/*   available [currently UNIX / Linux, Win32, OS/2]                  */
/*                                                                    */
/* * Delimited strings; a character (usually a SPACE) delimits a set  */
/*   of character sequences, each of which may be considered to be a  */
/*   'word' or 'element'. BIF's such as WORD, WORDS, and DELWORD allow*/
/*   delimited strings to model sets, records, and both single and    */
/*   multi-dimension arrays. Whilst very useful, they suffer from two */
/*   problems:                                                        */
/*                                                                    */
/*   - Immutable, so any modification sees a copy made [read: poor    */
/*     performance when compared to in-place modification]            */
/*                                                                    */
/*   - Cannot be [easily] nested, so do not have quite the utility of */
/*     true lists like those found in functional languages            */    
/*                                                                    */
/* In order to improve the readability of examples, and to avoid the  */
/* presence of too much redundant code, a number of custom helper     */
/* subroutines / functions will be used. Most of these routines are   */
/* functionally similar to Perl or Python counterparts such as 'split'*/
/* and 'join', while others are similar to Scheme routines such as    */
/* 'foreach', 'map', and 'reduce'. Code and documentation for these   */
/* will be found in the Appendix; listed here for easy reference:     */ 
/*                                                                    */
/* * Constructors / Finaliser                                         */
/*   - array = makeArray(var1, var2, ...)                             */
/*   - array = makeArrayRange(start, end, increment)                  */
/*   - dropArray(array1, array2, ...)                                 */
/*                                                                    */
/* * Array Manipulation                                               */
/*   - array = ajoin(array1, array2, ...)                             */
/*                                                                    */
/* * Perl / Python Hybrids                                            */
/*   - array = split(string, delimiter)                               */
/*   - array = chop(string, length)                                   */
/*   - string = join(array, delimiter)                                */
/*                                                                    */
/* * Functional Hybrids                                               */
/*   - forupdate(array, procname, procargs, ...)                      */
/*   - foreach(array, procname, procargs, ...)                        */
/*   - reduction = reduce(array, reduction, procname, procargs, ...)  */
/*   - array = map(array, procname, procargs, ...)                    */
/*                                                                    */
/* In addition, the 'rxHash' library will be used to implement other  */
/* useful data structure-handling routines, including:                */
/*                                                                    */
/* * ...                                                              */
/*                                                                    */
/* REXX purists will certainly criticise the approach taken as one    */
/* that is:                                                           */
/*                                                                    */
/* * Non-portable, particularly to 'large-system' environments        */ 
/* * Inefficient, particularly any use of the INTERPRET instruction   */
/* * Non-REXX idiomatic, by trying to mimic Python or Scheme idioms   */
/*                                                                    */
/* However, I simply wish to counter by saying that this approach:    */
/*                                                                    */
/* * Helps REXX examples more closely resemble the Perl-originals     */
/* * Non-compound variable 'arrays' are not REXX-idiomatic anyway, so */
/*   it shouldn't be a concern [compound variable use will be covered */
/*   in the chapter on hashes]                                        */
/* * Showcases the versatility of the REXX language                   */
/*                                                                    */
/* Third-party library directions:                                    */
/*                                                                    */
/* Use of 'rxHash' assumes the following prologue / epilogue:         */
/*                                                                    */
/*   call rxFuncAdd 'arrLoadFuncs', 'rxhash', 'arrLoadFuncs'          */
/*   call arrLoadFuncs                                                */
/*   ...                                                              */
/*   call arrDropFuncs                                                */
/*                                                                    */
/* whilst use of 'rexxUtil' requires:                                 */
/*                                                                    */
/*   call rxFuncAdd 'sysLoadFuncs', 'rexxutil', 'sysLoadFuncs'        */
/*   call sysLoadFuncs                                                */
/*   ...                                                              */
/*   call sysDropFuncs                                                */
/*                                                                    */
/* A final thing worth mentioning is the reason for using 'rxHash' to */
/* implement numerically-indexed arrays [which need to have elements  */
/* 'shuffled' when middle element insertions and deletions are made]  */
/* rather than other data structures like lists. The reason was so ma-*/
/* ximum utility could be maintained:                                 */
/*                                                                    */
/* * Only numeric arrays can easily be converted to compound variables*/
/*   [and vice versa] by library functions                            */
/* * Only numeric arrays can easily be sorted, both by a supplied lib-*/
/*   rary function [thus providing fast sorting] and in general, w/o  */
/*   the need for copying elememts                                    */
/* * Only numeric arrays are traversable via DO ... END; otherwise the*/
/*   'arrStemDoOver' has to be used, and it neither iterates in order */
/*   nor does it allow the number of elements to be discerned         */
/* ------------------------------------------------------------------ */

/* Load general-purpose functions from external library */
call rxFuncAdd 'sysLoadFuncs', 'rexxUtil', 'sysLoadFuncs'
call sysLoadFuncs

/* Load array functions from external library */
call rxFuncAdd 'arrLoadFuncs', 'rxHash', 'arrLoadFuncs'
call arrLoadFuncs

/* ----------------------------- */

nested = makeArray("this", "that", "the", "other") ; call arrDrop nested

/* ----------- */

/*
   NESTED arrays are possible, though somewhat awkward to use because
   references to any 'contained' arrays must be explicitly created
   and explicitly destroyed [though they can be inlined if the
   'containing' array will be freed using the 'dropArray' routine].
   The situation is analogous to managing C pointers [in fact, that
   *is* what is being done, albeit indirectly :)]
*/

/* Make inner array, store reference, add it as outer array element */
lvl_1 = makeArray("the", "other")
nested = makeArray("this", "that", lvl_1)

/* Take care to destroy inner array reference before container itself */
call arrDrop lvl_1 ; call arrDrop nested

/* ----------- */

/*
   Alternative to above, but *must* free with 'dropArray'; preferable
   to use latter anyway since it accepts multiple arguments except on
   large arrays, or those containing deeply-nested arrays
*/

nested = makeArray("this", "that", makeArray("the", "other"))

call dropArray nested

/* ----------------------------- */

tune = makeArray("The", "Star-spangled", "Banner") ; call dropArray tune

/* @@PLEAC@@_4.1 */
/* ------------------------------------------------------------------ */
/* Array management entails:                                          */
/*                                                                    */
/* * Creating an array, and saving its 'handle'                       */
/* * Using the handle for subsequent access, and updates              */
/* * Explicitly destroying the array via the handle; failure to do    */
/*   this will see memory leakages occur                              */
/*                                                                    */
/* Really no different to managing pointers in a language like C. Of  */
/* course since it is a library facility rather than an language elem-*/
/* ent, it is less convenient [i.e. no inlining of array creation cal-*/
/* -ls, no 'array literals' etc] to use.                              */
/* ------------------------------------------------------------------ */

a = makeArray("quick", "brown", "fox") ; call dropArray a

/* ----------------------------- */

a = split("Why are you teasing me?") ; call dropArray a

/* ----------------------------- */

lines = makeArray()

signal HEREDOC /*
The boy stood on the burning deck,
It was as hot as glass.
*/

HEREDOC:
  do i = SIGL + 1
    line = SOURCELINE(i)
    if line = "*/" then ; leave
    call asplice lines, -1, "IA", line
  end

call dropArray lines

/* ----------------------------- */

bigarray = makeArray()

parse value LINEIN("mydatafile.txt") with line
do while line <> NULL
  call asplice bigarry, -1, "IA", line
  parse value LINEIN("mydatafile.txt") with line
end

call dropArray bigarray

/* ----------------------------- */

banner = "The Mines of Moria"
banner = 'The Mines of Moria'

/* ----------------------------- */

name = "Gandalf"
banner = "Speak," name || ", and enter."

/* ----------------------------- */

his_host = "www.perl.com"

host_info = nslookup(his_host)

/* ----------- */

nslookup : procedure expose (globals)
  cmd = "nslookup" ARG(1) ; out = NULL
  address SYSTEM cmd with OUTPUT STEM cmdout.
  do i = 1 for cmdout.0 ; out = out NEWLINE cmdout.i ; end
  return STRIP(out)

/* ----------------------------- */

banner = makeArray("Costs", "only", "$4.95") ; call dropArray banner
banner = split("Costs only $4.95") ; call dropArray banner

/* ----------------------------- */

brax = split('"' "'" "( ) < > { } [ ]", SPACE)
rings = split("'They're" '"Nenya Narya Vilya"' || "'", SPACE)
tags = split("LI TABLE TR TD A IMG H1 P", SPACE)

call dropArray brax, rings, tags

banner = "The '\' is often used in regular expressions."

/* ----------------------------- */

/*
   For unicode support see 'rexxUtil' library's 'sysToUnicode' and
   'sysFromUnicode' functions
*/

/* @@PLEAC@@_4.2 */
say commify_series(NULL)
say commify_series("red")
say commify_series("red yellow")
say commify_series("red yellow green")

mylist = "red yellow green"
say "I have" commify_series(mylist) "marbles."

exit 0

/* ----------- */

commify_series : procedure expose (globals)
  if ARG() > 1 then ; return NULL

  list = ARG(1) ; n = WORDS(list) 

  select
    when n == 0 then ; return NULL
    when n == 1 then ; return WORD(list, 1)
    when n == 2 then ; return WORD(list, 1) "and" WORD(list, 2)
    otherwise
      series = WORD(list, 1)  
      do i = 2 to n - 1 ; series = series || "," WORD(list, i) ; end
      return STRIP(series) || ", and" WORD(list, n)
  end

/* ----------------------------- */

/*
   Implementation uses nested arrays
*/

data = makeArray(,
  makeArray("just one thing"),,
  split("Mutt Jeff"),,
  split("Peter Paul Mary"),,
  makeArray("To our parents", "Mother Theresa", "God"),,
  makeArray("pastrami", "ham and cheese",,
            "peanut butter and jelly", "tuna"),,
  makeArray("recycle tired, old phrases",,
            "ponder big, happy thoughts"),,
  makeArray("recycle tired, old phrases",,
            "ponder big, happy thoughts",,
            "sleep and dream peacefully"))

call foreach data, "print_list"

call dropArray data

exit 0

/* ----------- */

print_list : procedure expose (globals)
  say "The list is:" commify_series(ARG(1)) || "."
  return

/* -- */

commify_series : procedure expose (globals)
  if ARG() > 1 then ; return NULL

  /* handle array */
  if isArray(ARG(1)) then do
    current = ARG(1) ; n = getArray(current, 0) 

    select
      when n == 0 then ; return NULL
      when n == 1 then ; return getArray(current, 1)
      when n == 2 then ; return getArray(current, 1) "and",
                         getArray(current, 2)
      otherwise
        series = getArray(current, 1)  
        do i = 2 to n - 1
          current_word = getArray(current, i)
          if POS(",", current_word) > 0 then
            sepchar = ";"
          else
            sepchar = ","
          series = series || sepchar current_word
        end
        return STRIP(series) || sepchar "and" getArray(current, n)
    end

  end ; else do
    /* handle multi-word string */
    list = ARG(1) ; n = WORDS(list) 

    select
      when n == 0 then ; return NULL
      when n == 1 then ; return WORD(list, 1)
      when n == 2 then ; return WORD(list, 1) "and" WORD(list, 2)
      otherwise
        series = WORD(list, 1)  
        do i = 2 to n - 1
          current_word = WORD(list, i)
          if POS(",", current_word) > 0 then
            sepchar = ";"
          else
            sepchar = ","
          series = series || sepchar current_word
        end
        return STRIP(series) || sepchar "and" WORD(list, n)
    end
  end

/* @@PLEAC@@_4.3 */
/* ------------------------------------------------------------------ */
/* Arrays, as implemented in the REXXToolkit functions [see Appendix] */
/* using the 'rexxUtil' library, cannot be grown / shrunk to specified*/
/* sizes as most of the examples in this section require. Their size  */
/* does, however, dynamically alter as elements are added / removed   */
/* via applications of the 'asplice' function.                        */
/* ------------------------------------------------------------------ */

people = split("Crosby Stills Nash Young", SPACE)

call what_about_that_array people

/*
   Output:
   The list has 4 elements.
   The index of the last element is 4.
   Element #4 is Young.

   Note: REXX convention is for 1-based numerically-indexed arrays
*/

/* ----------- */

call asplice people, -1, 'D' 1
call what_about_that_array people

/*
   Output:
   The list has 3 elements.
   The index of the last element is 3.
   Element #4 is .

   Note: An invalid array element returns the empty-string, "" / NULL
*/

/* ----------------------------- */

/* Growing / shrinking arrays to specified sizes is inapplicable */

/* ----------------------------- */

call dropArray people

exit 0

/* ----------- */

what_about_that_array : procedure expose (globals)
  arr = ARG(1)
  say "The list has" arrGet(arr, 0) "elements."
  say "The index of the last element is" arrGet(arr, 0) || "."
  say "Element #4 is" arrGet(arr, 4) || "."
  return

/* @@PLEAC@@_4.4 */
/* ------------------------------------------------------------------ */
/* The canonical means of iterating in REXX is via the DO ... END con-*/
/* trol structure. To traverse an array [quickly]:                    */
/*                                                                    */
/*   do i = 1 for arrGet(oldarr, 0)                                   */
/*     call arrSet newarr, i, arrGet(oldarr, i)                       */
/*   end                                                              */
/*                                                                    */
/* or more safely:                                                    */
/*                                                                    */
/*   do i = 1 for getArrayLength(oldarr)                              */
/*     call setArray newarr, i, getArray(oldarr, i)                   */
/*   end                                                              */
/*                                                                    */
/* For convenience this functionality is packaged in the REXXToolkit's*/
/* 'foreach' and 'forupdate' functions. The former is modelled after  */
/* the 'foreach' routine that is found in many functional and scripti-*/
/* ng languages in which each element of a data structure is visited  */
/* and a specified function is invoked. 'forupdate' is a variant that */
/* updates each visited element.                                      */
/*                                                                    */
/* Of course if maximum performance is required, say, when working on */
/* very large arrays which may be traversed multiple times, an inline */
/* DO ... END structure that uses the array-access primitives like    */
/* 'arrGet' and 'arrSet', should be used.                             */  
/*                                                                    */
/* It is also worth noting that Perl seems to make little distinction */
/* between arrays and lists. In REXX, however, a language that doesn't*/
/* implement a 'list' data structure, it is common to see strings of  */
/* space-separated words used as lists, and use made of the PARSE ins-*/
/* truction to 'traverse the list' much as one might use CAR and CDR  */
/* in LISP or Scheme to do the same. Example:                         */
/*                                                                    */
/*   list = "one two three"                                           */
/*   do while list <> NULL                                            */
/*     parse var list token list                                      */
/*       ... do something with 'token' ...                            */
/*   end                                                              */
/* ------------------------------------------------------------------ */

mylist = makeArray(1, 2, 3, 4, 5) ; procname = "print"

call foreach mylist, procname

call dropArray mylist

exit 0

/* ----------- */

print : procedure expose (globals)
  say ARG(1) ; return

/* ----------------------------- */

bad_users = makeArray("Tom", "Dick", "Harry")

call foreach bad_users, "complain"

call dropArray bad_users

exit 0

/* ----------- */

complain : procedure expose (globals)
  say "You are a *** very bad *** user," ARG(1) ; return

/* ----------------------------- */

/* Extract environment data into a compound variable, and sort */
address SYSTEM "set" with OUTPUT STEM environ.
call sysStemSort 'environ.'

/* Array from compound variable; print with 'foreach' and helper */
arr = arrFromStem('environ.')
call foreach arr, "showEnvironInfo"

call dropArray arr ; drop environ.

/*
   A more idiomatic REXX approach would be to access the compound
   variable directly, so avoiding array conversion and access
   overhead:

   do i = 1 for environ.0
     parse value environ.i with key "=" val
     say key "=" val
   end
*/

exit 0

/* ----------- */

showEnvironInfo : procedure expose (globals)
  parse value ARG(1) with key "=" val
  say key "=" val ; return

/* ----------------------------- */

all_users = split(get_all_users(), SPACE)
MAX_QUOTA = get_max_quota()

call foreach all_users, "complain_if_overquota", MAX_QUOTA

call dropArray all_users

exit 0

/* ----------- */

complain_if_overquota : procedure expose (globals)
  user = ARG(1) ; MAX_QUOTA = ARG(2)
  if get_usage(user) > MAX_QUOTA then
    say "You are a *** very bad *** user," ARG(1)
  return

/* Dummy routines - used for illustration only */

get_max_quota : procedure expose (globals)
  return 100

get_all_users : procedure expose (globals)
  return "u1 u2 u3" 

get_usage : procedure expose (globals)
  quotas = "u1 99 u2 101 u3 102"
  return WORD(quotas, WORDPOS(ARG(1), quotas) + 1)

/* ----------------------------- */

/* Extract list of system users */
address SYSTEM "who|cut -d' ' -f1|uniq" with OUTPUT STEM users.

arr = arrFromStem('users.')

/*
   Iterate over array using 'arrDoOver'. Not strictly needed
   for numerically-indexed arrays, but quite handy for for
   non-numeric-indexed arrays
*/

userIdx = arrDoOver(arr)
do while userIdx \= NULL
  user = arrGet(arr, userIdx)
  if user == "tchrist" then do ; say user ; leave ; end
  userIdx = arrDoOver(arr)
end

call dropArray arr ; drop users.

/* ----------------------------- */

/*
   REXXToolkit function, 'areadfile', may be used to read file contents
   into an array; each element may be a line, word [optionally
   delimited], character, or specified number of characters
*/

arr = areadfile("lines.txt", 'W')

call foreach arr, "rev_and_print"

call dropArray arr

exit 0

/* ----------- */

rev_and_print : procedure expose (globals)
  say REVERSE(ARG(1)) ; return

/* ----------------------------- */

arr = makeArray(1, 2, 3, 4, 5)

call foreach arr, "print"

call dropArray arr

exit 0

/* ----------- */

print : procedure expose (globals)
  say "i =" ARG(1) ; return

/* ----------------------------- */

/*
   REXXToolkit function, 'forupdate', is a mutating version of,
   'foreach' [it updates array elements], thus complements the
   latter quite well. There is also a 'map' function which is
   similar except that it returns a new array leaving the source
   array untouched
*/

arr = makeArray(1, 2, 3)

call forupdate arr, "incr", -1

call dropArray arr

exit 0

/* ----------- */

incr : procedure expose (globals)
  return ARG(1) + ARG(2)

/* ----------------------------- */

a = makeArray(0.5, 3) ; b = makeArray(0.5, 3)

call forupdate_seq a, b, "mul", 7

call dropArray a, b

exit 0

/* ----------- */

mul : procedure expose (globals)
  return ARG(1) * ARG(2)

/* ----------------------------- */

/*
   'foreach' and 'forupdate' only work with arrays - to also use
   these functions with simple variables [scalars] and compound
   variable [hashes], first convert the items to arrays ...
*/

scalar = 1 ; hash.0 = 3 ; hash.1 = 3 ; hash.2 = 6 ; hash.3 = 7

a = makeArray(scalar) ; b = makeArray(...) ; c = arrFromStem('hash.')

call forupdate_seq a, b, c, "do_trim"

call dropArray a, b, c

exit 0

/* ----------- */

do_trim : procedure expose (globals)
  return STRIP(ARG(1))

/* @@PLEAC@@_4.5 */
/* ------------------------------------------------------------------ */
/* The REXXToolkit array functions are all passed one or more array   */
/* references. Consequently the examples in this section illustrate   */
/* functionality that has already been showcased in the previous sect-*/
/* ion. Therefore, only one example will be implemented.              */ 
/* ------------------------------------------------------------------ */

fruits = makeArray("Apple", "Blackberry")

/* Pointless to do this in REXX */
fruit_ref = fruits

call foreach fruit_ref, "print"

call dropArray fruit_ref

exit 0

/* ----------- */

print : procedure expose (globals)
  say ARG(1) "tastes good in a pie." ; return

/* @@PLEAC@@_4.6 */
/* ------------------------------------------------------------------ */
/* The simplest way of removing duplicates is to use a data structure */
/* that does so: a set is the usual candidate [illustarted below]. In */
/* the absence of such a facility, more verbose approaches are needed,*/
/* and, in the tradition of the Perl Cookbook, here are some of them !*/
/* Also illustrated are the REXXToolkit's set and hash table routines */
/* ------------------------------------------------------------------ */

/*
   The following code is modelled on the first example, making use of
   a hash table to weed out duplicates and allow values to be loaded
   from one array to another
*/

list = split(" ... ", SPACE) ; uniq = makeArray() ; seen = makeHash()

call foreach list, "uniq_if_not_seen", uniq, seen

/* ... do something with 'uniq' ... */

call dropArray list, uniq, seen

exit 0

/* ----------- */

uniq_if_not_seen : procedure expose (globals)
  key = ARG(1) ; uniq = ARG(2) ; seen = ARG(3)
  if hashExist(seen, key) then ; return
  call hashPut seen, key, TRUE ; call asplice uniq, -1, "IA", key
  return

/* ----------------------------- */

/*
   A, rather contrived, variation of the above making use of
   string parsing and a hash table  
*/

list = " ... " ; seen = makeHash() ; uniq = makeArray()

do while list <> NULL
  parse var list key list ; call hashPut seen, key, TRUE
end

uniqp = hashToPairs(seen)

do while uniqp <> NULL
  parse var uniqp key ":" value uniqp ; call asplice uniq, -1, "IA", key
end

/* ... do something with 'uniq' ... */

call dropArray uniq, seen

exit 0

/* ----------------------------- */

/*
   A much simpler alternative to all the above is to create a set, then 
   extract an array from that set
*/

set = setFromStr(" ... ") ; uniq = arrFromSet(set)

/* ... do something with 'uniq' ... */

call dropArray uniq, set

exit 0

/* ----------------------------- */

/*
   Duplicates removed through type conversion:
   - user list obtained as a compound variable [i.e. stem]
   - convert stem to array, then array to set [removes duplicates]
   - convert set to string for parsing, printing etc
*/

address SYSTEM "who|cut -d' ' -f1" with OUTPUT STEM ustem.
uarr = arrFromStem('ustem.') ; uset = setFromArr(uarr)
users = strFromSet(uset)

/* Print user list as a single line */
say "users logged in:" users

/*
   Free all intermediate data structures [stems and strings are
   native] so no explicit freeing required
*/
call dropArray uarr, uset

exit 0

/* @@PLEAC@@_4.7 */
/* ------------------------------------------------------------------ */
/* Most of the examples in this section are, at core, set difference  */
/* operations, so can be easily and compactly solved if set type or   */
/* set operation routines are available. Otherwise it involves rather */
/* labourious multiple hash table lookup and traversal, an approach   */
/* taken by most of the Perl examples.                                */
/* ------------------------------------------------------------------ */

/* Assume, 'a_arr' and 'b_arr' exist, and will not be freed here */

seen = makeHash()

call foreach a_arr, "add_if_not_seen", seen
call foreach b_arr, "drop_if_seen", seen

a_only = hashKeys(seen)

/* ... do something with 'a_only' ... */

call dropArray a_only, seen

exit 0

/* ----------- */

add_if_not_seen : procedure expose (globals)
  key = ARG(1) ; seen = ARG(2)
  if hashExist(seen, key) then ; return
  call hashPut seen, key, TRUE ; return

/* ----------- */

drop_if_seen : procedure expose (globals)
  key = ARG(1) ; seen = ARG(2)
  call hashDrop seen, key ; return

/* ----------------------------- */

/* 
   The simplest way is by using the REXXToolkit's 'setd' routine to
   perform a 'set difference' operation
*/

/* Assume, 'a_arr' and 'b_arr' exist, and will not be freed here */

/* Convert arrays to sets, removing any duplicates in the process */
a_set = setFromArr(a_arr) ; b_set = setFromArr(b_arr)

/* Create a new set of items in 'a_set', but not in 'b_set' */
a_only = setd(a_set, b_set)

/* ... do something with 'a_only' ... */

/* Free intermediate data structures */
call dropArray a_set, b_set, a_only

exit 0

/* ----------------------------- */

/*
   Hash table usage examples ?
*/

/* Create empty hash table, add a couple of items */
hash = makeHash()

call hashPut hash, "key1", 1 ; call hashPut hash, "key2", 2 

call dropArray hash

/* ----------- */

/*
   Multiple values can be added when converting from a
   string of key:value pairs
*/
hash = hashFromPairs("key1:value key2:value...")

/* ----------- */

/* Empty hash table by freeing it and creating another */
call dropArray hash ; hash = makeHash()

/* @@PLEAC@@_4.8 */
/* ------------------------------------------------------------------ */
/* REXXToolkit implements several set manipulation routines which make*/
/* all manner of set operations quite straightforward. The examples   */
/* follow the Perl lead, though this isn't the implementation route   */
/* that would ordinarily be taken. Note: this section uses the array  */
/* manipulation routines [getArray, setArray, getArrayLength] as an   */
/* alternative to the 'foreach' and 'forupdate' routines.             */
/* ------------------------------------------------------------------ */

/*
   Preferred approach: REXXToolkit set routines   
*/

a = makeSet(1, 3, 5, 6, 7, 8) ; b = makeSet(2, 3, 5, 7, 9)

union = setu(a, b) ; isect = seti(a, b) ; diff = setd(a, b)

call dropArray a, b, union, isect, diff

/* ----------------------------- */

a_arr = makeArray(1, 3, 5, 6, 7, 8) ; b_arr = makeArray(2, 3, 5, 7, 9)

union_hash = makeHash() ; isect_hash = makeHash()
diff_hash = makeHash()

/* ----------- */

do i = 1 to getArrayLength(a_rr)
  call hashPut union_hash, getArray(a_arr, i), TRUE
end

do i = 1 to getArrayLength(b_rr)
  if hashExist(union_hash, getArray(b_arr, i)) then
    call hashPut isect_hash, getArray(b_arr, i), TRUE
  call hashPut union_hash, getArray(a_arr, i), TRUE
end

union_arr = hashKeys(union_hash) ; isect_arr = hashKeys(isect_hash)

call dropArray union_arr, isect_arr

/* ----------- */

call foreach_seq a_arr, b_arr, "isect_if_not_union", union_hash,,
                 isect_hash

union_arr = hashKeys(union_hash) ; isect_arr = hashKeys(isect_hash)

call dropArray union_arr, isect_arr

exit 0

/* -- */

isect_if_not_union : procedure expose (globals)
  key = ARG(1) ; union = ARG(2) ; isect = ARG(3)
  if hashGet(union, key) \= TRUE then ; call hashPut isect, key, TRUE
  call hashPut union, key, TRUE ; return

/* ----------- */

count_hash = makeHash()

call foreach_seq a_arr, b_arr, "count_keys", count_hash

call dropArray union_arr, isect_arr, diff_arr

union_arr = makeArray() ; isect_arr = makeArray()
diff_arr = makeArray()

count_keys = hashKeys(count_hash) 

call foreach count_keys, "select_count_members",,
             count_hash, union_arr, isect_arr, diff_arr

call dropArray count_hash, count_keys

exit 0

/* -- */

count_keys : procedure expose (globals)
  key = ARG(1) ; count = ARG(2)
  if \hashExist(count, key) then do
    call hashPut count, key, 1 ; return
  end
  call hashPut count, key, (hashGet(count, key) + 1)
  return

/* -- */

select_count_members : procedure expose (globals)
  key = ARG(1) ; count_hash = ARG(2) ; union_arr = ARG(3)
  isect_arr = ARG(4) ; diff_arr = ARG(5)
  call asplice union_arr, -1, "IA", key
  if hashGet(count, key) == 2 then
    call asplice isect_arr, -1, "IA", key
  else
    call asplice diff_arr, -1, "IA", key
  return

/* ----------- */

call dropArray a_arr, b_arr, union_arr, isect_arr, union_hash,,
               isect_hash, diff_hash

/* ----------------------------- */

/* @@PLEAC@@_4.9 */
/*
   Use REXXToolkit function, 'ajoin' [see Appendix]. It may be used to
   concatenate two or more arrays; by default it modifies the first
   specified array, but may be used to create a new array
*/

arr1 = makeArray(...) ; arr2 = makeArray(...)

/* New array from concatenation of 'arr1' and 'arr2' */
arr3 = ajoin(arr1, arr2, 'C')

call dropArray arr1, arr2, arr3

/* ----------- */

arr1 = makeArray(...) ; arr2 = makeArray(...)

/* 'arr1' modified */
call ajoin arr1, arr2

call dropArray arr1, arr2

/* ----------------------------- */

members = makeArray("Time", "Flies")
initiates = makeArray("An", "Arrow")

/* 'members' modified: ("Time", "Flies", "An", "Arrow") */
call ajoin members, initiates

/* ----------- */

/*
  Use REXXToolkit function, 'asplice', to alter array contents
  [see Appendix]; a handy alternative to explicitly using array
  indexes e.g.

    call asplice members, -2, 'R', "A", "Banana"

  or:

    /* Fast, but crashes if 'members' is not an array */
    call arrSet members, (arrGet(members, 0) - 1), "A"
    call arrSet members, (arrGet(members, 0)), "Banana"

  or:

    /* Slower, but safer, than previous example */
    call setArray members, (getArrayLength(members) - 1), "A"
    call setArray members, (getArrayLength(members)), "Banana"
*/

call asplice members, 2, 'IA', "Like", initiates
printArray members

call asplice members, 1, 'R', "Fruit"
call asplice members, -2, 'R', "A", "Banana"
printArray members

/*
   was: ("Time", "Flies", "An", "Arrow")
   now: ("Fruit", "Flies", "Like", "A", "Banana")
*/

/* ----------- */

call dropArray members, initiates

/* @@PLEAC@@_4.10 */
arr = makeArray(4, 7, 2, 8, 3, 1) ; alen = arrGet(arr, 0)

i = 1 ; j = alen

do until i > j
  t = arrGet(arr, j)
  call arrSet arr, j, arrGet(arr, i) ; call arrSet arr, i, t
  i = i + 1 ; j = j - 1
end

call dropArray arr

/* ----------------------------- */

arr = makeArray(4, 7, 2, 8, 3, 1)

/* Use REXXToolkit function, 'areverse' [see Appendix] */

/* Reverse a copy of the array */
cpy = areverse(arr, 'C')

/* In-place reverse array */
call areverse arr

call dropArray arr, cpy


/* @@PLEAC@@_4.16 */
/*
   Example modelled directly on Perl code
*/

processes = makeArray(1, 2, 3, 4, 5)

do forever
  process = grab_and_rotate(processes)
  say "Handling process" process
  call sysSleep 1
end

call dropArray processes

/* ----------- */

grab_and_rotate : procedure expose (globals)
  arr = ARG(1)
  call asplice arr, -1, 'IA', getArray(arr, 1)
  call asplice arr, 1, 'D' 1
  return getArray(arr, 1)

/* ----------------------------- */

/*
   Example utilising the REXX 'string as list' idiom
*/

processes = "1 2 3 4 5"

do forever
  process = WORD(processes, 1)
  processes = grab_and_rotate(processes)
  say "Handling process" process
  call sysSleep 1
end

/* ----------- */

grab_and_rotate : procedure expose (globals)
  list = ARG(1) ; return DELWORD(list, 1, 1) WORD(list, 1)

/* @@PLEAC@@_4.17 */
alen = ... ; arr = makeArrayRange(1, alen, 1)

/* Fischer-Yates Shuffle */
do i = alen to 1 by -1
  j = RANDOM(1, i) ; if i == j then ; iterate
  tmp = arrGet(arr, i) ; call arrSet arr, i, arrGet(arr, j)
  call arrSet arr, j, tmp
end

/* ----------- */

/* Naive Shuffle */
do alen
  p1 = RANDOM(1, alen) ; p2 = RANDOM(1, alen)
  do while p2 == p1 ; p2 = RANDOM(1, alen) ; end
  tmp = arrGet(arr, p1) ; call arrSet arr, p1, arrGet(arr, p2)
  call arrSet arr, p2, tmp
end

call dropArray arr

/* ----------------------------- */

alen = ... ; arr = makeArrayRange(1, alen, 1)

/* Use REXXToolkit function, 'ashuffle' [see Appendix] */

/* Shuffle a copy of the array */
cpy = ashuffle(arr, 'C')

/* In-place shuffle array */
call ashuffle arr

call dropArray arr, cpy

/* @@PLEAC@@_4.18 */
@@INCOMPLETE@@
@@INCOMPLETE@@

/* @@PLEAC@@_4.19 */
@@INCOMPLETE@@
@@INCOMPLETE@@

/* @@PLEAC@@_5.0 */
/* ------------------------------------------------------------------ */
/* Where Perl implements 'hashes', REXX offers 'compound variables' to*/
/* fulfil the same role [they are each, after all, associative array  */
/* implementations]. Additionally, it is important to understand that */
/* compound variables are not simply another data structure, but a key*/
/* REXX feature - many REXX idioms involve compound variable use. For */
/* example, external library functions such as those from the 'rxSock'*/
/* library [i.e. TCP/IP sockets] use compound variables to exchange   */
/* multi-valued data such as host name/address and port number aggre- */
/* gations. Another use is the making available the lines of a file as*/
/* compound variable 'leaves', where, for example, the five lines read*/
/* from 'infile.txt' into a compound variable called 'infile.', would */
/* be accessable as, 'infile.1' through 'infile.5'; each 'leaf' is    */
/* named after the corresponding line number. Note also that the term */
/* 'stem variable' is sometimes used to describe compound variables.  */
/*                                                                    */
/* By adopting certain design conventions, compound variables may be  */
/* used to build high-level data structures like lists and trees,     */
/* build 'associations' between items [i.e. property lists], as well  */
/* as mimic data structures like records / structures, and also single*/
/* and multi-dimensional arrays [both numerically and non-numerically */
/* indexed]. However, it will be their use as 'hashes' that will be   */
/* disccussed here.                                                   */
/*                                                                    */
/* Whilst compound variables are quite versatile, there are a number  */
/* of quirks associated with their use:                               */
/*                                                                    */
/* * Indexing is via the '.' operator. This usage can be confusing for*/
/*   those used to using this operator to access structure members [as*/
/*   in C or Java]. Furthermore, the '[]' operator, commonly used as  */
/*   an array index operator, is not available [though it is in more  */
/*   recent REXX implementations like ooREXX]                         */
/*                                                                    */
/* * They cannot be passed to, nor returned from, REXX subroutines, by*/
/*   reference [though it is possible to pass the name of such items  */
/*   and access their contents indirectly via the VALUE BIF]. It is,  */
/*   however, possible to pass the name of a compound variable to an  */
/*   external library function and have it access and/or 'fill' it    */
/*   with data                                                        */
/*                                                                    */
/* * Index names must either be literals, or variables; expressions   */
/*   cannot be used [they would need to be assigned to a variable, and*/
/*   the variable used for indexing]                                  */
/*                                                                    */
/* * There is no instruction or BIF for traversing compound variable  */
/*   members. In order to allow such an operation, it is typical to:  */
/*                                                                    */
/*   - Use numerically-based indexes [index '0' has total items] e.g. */
/*                                                                    */
/*     cv.1 = "first" ; cv.2 = "second" ; cv.3 = "third" ; cv.0 = 3   */
/*                                                                    */
/*     do i = 1 to cv.0                                               */
/*       say cv.i                                                     */
/*     end                                                            */
/*                                                                    */
/*   - Use a purpose-built, external library function. 'regStemDoOver'*/
/*     from the *NIX / Win32 implementation of the 'rexxUtil' library */
/*     is one such function                                           */
/*                                                                    */
/* * It is not possible to manually sort or merge compound variables  */
/*   unless numerically-based indexes are used [or purpose-built, ext-*/
/*   ernal library function used]. Similarly, certain external library*/
/*   functions [e.g. 'sysStemInsert', 'sysStemDelete' etc] will only  */
/*   work with compound variables following this convention           */
/*                                                                    */
/* Owing to these quirks, it is common to see use made of compound    */
/* variables with numerically-based indexes where there is a need for */
/* non key-based searching, or where data needs to be sorted. Also, a */
/* compound variable will tend to be shared among subroutines, usually*/
/* via the 'EXPOSE' instruction, in the same manner as a global value.*/
/*                                                                    */
/* Several examples make use of 'rexxUtil' library functionality, so  */
/* assume the existence of the following prologue code:               */
/*                                                                    */
/*     call rxFuncAdd 'sysLoadFuncs', 'rexxUtil', 'sysLoadFuncs'      */
/*     call ssyLoadFuncs                                              */
/*                                                                    */
/* and the following epilogue code [usually at program's end]:        */
/*                                                                    */
/*     call sysDropFuncs                                              */
/* ------------------------------------------------------------------ */

/* Create compound variable, 'age.', uninitialised variables as keys */

age.Nat = 24                         /* Equivalent to: age."NAT" */
age.Jules = 24                       /* ... age."JULES" */
age.Josh = 17                        /* ... age."JOSH" */

/* ----------------------------- */

/* As previous; used from subroutine when stem name runtime-supplied */
stem = "age."
key = "Nat" ; call VALUE stem||key, 24
key = "Jules" ; call VALUE stem||key, 24
key = "Josh" ; call VALUE stem||key, 17

/* ----------------------------- */

/* Preferred approach [key placed in variable] as keys retain case */
key = "Nat" ; age.key = 24
key = "Jules" ; age.key = 24
key = "Josh" ; age.key = 17

/* As previous, except key-value pairs parsed from list */
name_list = "Nat 24 Jules 24 Josh 17"
do while name_list <> NULL
  parse var name_list key age.key name_list
end

/* ----------------------------- */

key = "Apple" ; food_color.key = "red"
key = "Banana" ; food_color.key = "yellow"
key = "Lemon" ; food_color.key = "yellow"
key = "Carrot" ; food_color.key = "orange"

/* As previous, except key-value pairs parsed from list */
food_list = "Apple red Banana yellow Lemon yellow Carrot orange"
do while food_list <> NULL
  parse var food_list key food_color.key food_list
end

/* @@PLEAC@@_5.1 */
/* ------------------------------------------------------------------ */
/* The rules for leaf [i.e. element, key / value] addition are simple:*/
/*                                                                    */
/* * If a leaf exists, then its content is replaced with the new value*/
/*                                                                    */
/* * If a leaf does not exist, then a new leaf is created, and the new*/
/*   value stored there                                               */
/*                                                                    */
/* The external library function, 'sysStemInsert', may also be used   */
/* provided the compound variable uses numerically-based indexes.     */
/* ------------------------------------------------------------------ */

key = "...key..." ; mydict.key = "...value..."

/* ----------------------------- */

key = "Raspberry" ; food_color.key = "pink"

/* Traverse compound variable using external ['rexxUtil'] function */
say "Known foods:"
do while regStemDoOver('food_color.', 'food')
  say food "is" food_color.food
end

/* @@PLEAC@@_5.2 */
/* ------------------------------------------------------------------ */
/* The built-in function [BIF], 'SYMBOL', is used to check whether a  */
/* particular leaf / key already exists. Note, however, effective use */
/* of this technique requires that the compound variable *not* be set */
/* to default values via:                                             */
/*                                                                    */
/*     cv. = DEFAULT_VALUE                                            */
/*                                                                    */
/* otherwise a 'SYMBOL' call will always indicate that the leaf / key */
/* exists even if it has not been explicitly added. In such cases the */
/* testing for leaf / key presence sees a content comparision with the*/
/* default value:                                                     */
/*                                                                    */
/*     if cv.key \= DEFAULT_VALUE then ; say "Key defined"            */
/*     else ; say "No such key defined"                               */
/*                                                                    */
/* In other words [and as illustrated below] there is no distinction  */
/* between an 'exists' test and a 'defined' test when a compound var- */
/* iable is default-valued. This is a behaviour which can easily trap */
/* the unwary.                                                        */
/* ------------------------------------------------------------------ */

/* Does 'mydict' have a value for KEY ? */

key = "..."

if SYMBOL('mydict.key') == 'VAR' then
  /* Key exists */
  nop
else
  /* No such key */
  nop

/* ----------------------------- */

food_list = "Banana Martini"

/* 1: Parse list using WORD-based BIF's and counted loop */
numberOfWords = WORDS(food_list)

do i = 1 for numberOfWords
  name = WORD(food_list, i)
  if SYMBOL('food_color.name') == 'VAR' then
    say name "is a food."
  else
    say name "is a drink."
end

/* 2: Parse list using PARSE instruction with conditional loop */
do while food_list <> NULL
  parse var food_list name food_list
  if SYMBOL('food_color.name') == 'VAR' then
    say name "is a food."
  else
    say name "is a drink."
end

/* ----------------------------- */

drop age.

key = "Toddler" ; age.key = 3
key = "Unborn" ; age.key = 0
key = "Phantasm" ; age.key = NULL

do i = 1
  thing = WORD("Toddler Unborn Phantasm Relic", i)
  if thing = NULL then ; leave
  call CHAROUT , thing||": "
  if SYMBOL('age.thing') == 'VAR' then do
    call CHAROUT , "Exists "
    if age.thing \= NULL then ; call CHAROUT , "Defined"
  end
  call LINEOUT , NULL
end

/* ----------------------------- */

/* Read a file-based list of filenames; store their sizes in a hash */
do forever
  parse value STRIP(LINEIN("filelist.txt")) with filename
  if filename == NULL then ; leave
  if SYMBOL('size.filename') \= 'VAR' then
    size.filename = STREAM(filename, 'C', "QUERY SIZE")
end

/* @@PLEAC@@_5.3 */
/* ------------------------------------------------------------------ */
/* The DROP instruction may be used both to:                          */
/*                                                                    */
/* * Remove a specific leaf / key [e.g. drop cv.key]                  */
/*                                                                    */
/* * Destroy the entire compound variable [e.g. drop cv.]             */
/*                                                                    */
/* The external library function, 'sysStemDelete', may also be used   */
/* provided the compound variable uses numerically-based indexes.     */
/* ------------------------------------------------------------------ */

/* Remove KEY and its value from 'mydict' */

key = "...key..." ; drop mydict.key

/* ----------------------------- */

say "Intially"
call print_foods

say "With Banana set to None"
key = "Banana" ; food_color.key = NULL
call print_foods

say "With Banana deleted"
key = "Banana" ; drop food_color.key
call print_foods

exit 0

/* ----------------------------- */

print_foods : procedure expose food_color. (globals)
  keys = NULL ; values = NULL

  do while regStemDoOver('food_color.', 'food')
    keys = keys food
    if food_color.food \= NULL then
      values = values food_color.food
    else
      values = values "undef"
  end

  say "Keys:  " keys
  say "Values:" values

  return

/* ----------------------------- */

key = "Banana" ; drop food_color.key
key = "Apple" ; drop food_color.key
key = "Cabbage" ; drop food_color.key

/* As previous, except keys parsed from list */
key_list = "Banana Apple Cabbage"
do while key_list <> NULL
  parse var key_list key key_list
  drop food_color.key
end

/* @@PLEAC@@_5.4 */
/* ------------------------------------------------------------------ */
/* Compound variable traversal may be accomplished two ways:          */
/*                                                                    */
/* * Via 'do ... end' instruction if the compound variable follows the*/
/*   numeric index convention [i.e. cv.0 = N ; elements: cv.1 .. cv.N]*/
/*                                                                    */
/* * Via external library function like 'rexxUtil's 'regStemDoOver',  */
/*   which may be used to traverse *any* compound variable, or create */
/*   a numerically indexed copy of an existing compound variable      */
/* ------------------------------------------------------------------ */

cv.0 = N                    /* Number of data items */
cv.1 = "..." ; cv.N = "..." /* Data */

do i = 1 for cv.0
  /* do something with index and value */
  say i "==>" cv.i
end

/* ----------- */

do while regStemDoOver('compound_variable_name.', 'key')
  /* do something with key and value */
  say key "==>" compound_variable_name.key
end

/* ----------------------------- */

/* Numeric index-based compound variable traversal */

cv.0 = 5 /* Number of data items */
cv.1 = 23 ; cv.2 = 734 ; cv.3 = 152 ; cv.4 = 876 ; cv.5 = 91  /* Data */

do i = 1 for cv.0
  say "Element" i "contains" cv.i
end

/* ----------- */

/* Same using external ['rexxUtil'] function [order not guaranteed] */

do while regStemDoOver('cv.', 'i')
  if i == "0" then ; iterate /* Exclude 'cv.0' */
  say "Element" i "contains" cv.i
end

/* ----------------------------- */

/* Non-numeric index-based traversal [order not guaranteed] */

say "Known foods:"
do while regStemDoOver('food_color.', 'food')
  say food "is" food_color.food
end

/* ----------- */

/* Non-numeric index-based *ordered* traversal */

/* 1: Create numeric index-based compound variable of *keys* */
do i = 1 while regStemDoOver('food_color.', 'food')
  idx_food_color.i = food ; idx_food_color.0 = i
end

/* 2: Sort the new compound variable */
call sysStemSort 'idx_food_color.'

/* 3: Traverse key-sorted compound variable; use lookup for values */
do i = 1 for idx_food_color.0
  key = idx_food_color.i
  say "Element" i "contains" LEFT("[" || key || "]", 8) " ==>",
      food_color.key
end

/* @@PLEAC@@_5.5 */
/* ------------------------------------------------------------------ */
/* Printing a compound variable is merely a special case of traversal */
/* therefore all examples shown in the previous section apply.        */
/* ------------------------------------------------------------------ */

/* *** All examples in previous section apply here also *** */

/* @@PLEAC@@_5.6 */
/* ------------------------------------------------------------------ */
/* Insertion order is not part of a compound variable's metadata. If  */
/* needed, an insertion-order index could be stored in a seperate     */
/* compound variable, most likely a numerically-indexed one. Each     */
/* index would itself indicate insertion order [i.e. .1 before 2. and */
/* so on]. However such metadata could be lost if sorting occurs or   */
/* there are frequent deletions and accompanying reuse of indexes.    */
/* ------------------------------------------------------------------ */

/* Store insertion order metadata in separate compound variable */
key = "Banana" ; food_color.key = "yellow" ; food_color_order.1 = key
key = "Apple" ; food_color.key = "red" ; food_color_order.2 = key
key = "Lemon" ; food_color.key = "yellow" ; food_color_order.3 = key
food_color_order.0 = 3

say "In insertion order, the foods are:"
do i = 1 to food_color_order.0
  say "   " food_color_order.i
end

say "Still in insertion order, the foods' colors are:"
do i = 1 to food_color_order.0
  key = food_color_order.i
  say key "is colored" food_color.key
end

/* @@PLEAC@@_5.7 */
/* ------------------------------------------------------------------ */
/* Multiple values per leaf / key can easily be accommodated if stored*/
/* as REXX lists [i.e. SPACE-delimited strings]. Related issues:      */
/*                                                                    */
/* * PARSE instruction or WORD BIF's can be used to extract required  */
/*   value                                                            */
/*                                                                    */
/* * Values may simply be appended, or ordered insertions made, the   */
/*   latter useful for search [binary search can be used] or reporting*/
/*   purposes                                                         */
/* ------------------------------------------------------------------ */

cmd = "who" ; address SYSTEM cmd with OUTPUT FIFO ''

do while QUEUED() > 0
  parse pull user tty .

  /* Insert values in ascending order so no sorting later needed */
  if SYMBOL('ttys.user') == 'VAR' then
    ttys.user = insertWord(tty, ttys.user)
  else
    ttys.user = tty
end

do while regStemDoOver('ttys.', 'user')
  say user || ":" ttys.user
end

exit 0

/* ----------------------------- */

insertWord : procedure
  V = ARG(1) ; S = STRIP(ARG(2)) ; R = WORDS(S)
  if R < 1 then ; return V
  L = 1

  do while L <= R
    M = (L + R) % 2 ; W = WORD(S, M)
    if V = W then ; return S
    if V < W then ; R = M - 1 ; else L = M + 1
  end

  /* insert [after] item here */
  select
    when R < 1 then ; insertAfter = 0
    when L > WORDS(S) then ; insertAfter = LENGTH(S) + 1
    otherwise
      if M = R then ; insertAfter = WORDINDEX(S, M + 1) - 1
      else ; insertAfter = WORDINDEX(S, M) - 1
  end

  return INSERT(V, S, insertAfter, LENGTH(V) + 1)

/* @@PLEAC@@_5.8 */
/* ------------------------------------------------------------------ */
/* This task requires that an existing compound variable be traversed */
/* and a new compound variable created in which the contents of each  */
/* of the existing compound variable's entries becomes a key in the   */
/* new compound variable, and the corresponding key, its contents.    */
/*                                                                    */
/* A decision as to how duplicate new keys will be handled is needed. */
/* ------------------------------------------------------------------ */

key = "Mantle" ; surname.key = "Mickey" ; key = "Ruth" ; surname.key =
"Babe"

/*
   Mantle Mickey
   Ruth Babe
*/
do while regStemDoOver('surname.', 'name')
  say name surname.name
end

/* Invert key <==> value */
do while regStemDoOver('surname.', 'name')
  key = surname.name ; firstname.key = name
end

/*
   Mickey Mantle
   Babe Ruth
*/
do while regStemDoOver('firstname.', 'name')
  say name firstname.name
end

/* ----------------------------- */

if ARG() < 1 then do ; say "usage: foodfind food|color" ; exit 1 ; end

given = ARG(1)

key = "Apple" ; color.key = "red"
key = "Banana" ; color.key = "yellow"
key = "Lemon" ; color.key = "yellow"
key = "Carrot" ; color.key = "orange"

/* Invert key <==> value */
do while regStemDoOver('color.', 'food')
  key = color.food ; food.key = food
end

if SYMBOL('color.given') == 'VAR' then
  say given "is a food with color" color.given

if SYMBOL('food.given') == 'VAR' then
  say food.given "is a food with color" given

exit 0

/* @@PLEAC@@_5.9 */
/* ------------------------------------------------------------------ */
/* The only means of sorting [i.e. ordering the leaves or their data] */
/* of a compound variable is to:                                      */
/*                                                                    */
/* * Ensure the compound variable has a numerically-based index struc-*/
/*   ture [i.e. is an NICV; if not, copy data and create one]         */
/*                                                                    */
/* * Use one of:                                                      */
/*                                                                    */
/*   - External library sort routine ['rexxUtil's 'sysStemSort']      */
/*   - Custom-written native REXX sort routine                        */
/*   - External sort utility via the ADDRESS instruction [Regina-only]*/
/*                                                                    */
/* Use of an external library sort routine is the most preferable as  */
/* it not only avoids the need to write such code, but is also the    */
/* most efficient since it is machine code acting directly on data,   */
/* and avoiding the data conversion that would be needed in the case  */
/* of a custom-written native REXX routine. However the latter is the */
/* most flexible since there is the widest choice of sort algorithm   */
/* available.                                                         */
/*                                                                    */
/* Generally speaking, the use of an ADDRESS instruction-based sort   */
/* should be avoided unless a very large [i.e. 1MB or more] amount of */
/* data is being handled, or data is file-based, in which case it is  */
/* a reasonable means of loading data into a compound variable since  */
/* the load / sort step is combined.                                  */
/*                                                                    */
/* Strange as it may seem, REXX does not offer a built-in function    */
/* [BIF] for sorting. This is a legacy of its mainframe origins; in   */
/* such environments data sorting tends to be performed on enormous   */
/* amounts of file-based [rather than memory-resident] data, and is a */
/* task reserved for specialised sorting utilities eg. DFSORT utility */
/* on IBM's MVS operating system.                                     */
/* ------------------------------------------------------------------ */

/* Numerically-indexed compound variable */

cv.0 = N                    /* Number of data items */
cv.1 = "..." ; cv.N = "..." /* Data */

/* ----------- */

/* 1: External Library Sort Routine */

call sysStemSort 'cv.', 'ascending'

/* ----------- */

/* 2: Custom REXX Sort Routine */

/* Version with direct access to, 'cv.' */
call mySortRoutine

/* Generic version which is passed a compound variable name */
call myGenericSortRoutine 'cv.'

/* ----------- */

/* 3: ADDRESS Instruction using Sort Utility [Regina-only] */

cmd = "sort"
address SYSTEM cmd with INPUT STEM cv. OUTPUT REPLACE STEM cv.

/* ----------------------------- */

mySortRoutine : procedure expose cv.
  swp = 1
  do while swp
    swp = 0
    do i = 2 to cv.0
      n = i - 1
      if cv.n > cv.i then ; parse value 1 cv.n cv.i with swp cv.i cv.n
    end
  end
  return

/* ----------------------------- */

myGenericSortRoutine :
  _stm = ARG(1) ; if RIGHT(_stm, 1) \= "." then ; _stm = _stm || "."
  _size = VALUE(_stm||"0") ; _swp = 1
  do while _swp
    _swp = 0
    do _i = 2 to _size
      _n = _i - 1
      if VALUE(_stm||_n) > VALUE(_stm||_i) then do
        _swp = 1 ; _tmp = VALUE(_stm||_i)
        call VALUE _stm||_i, VALUE(_stm||_n) ; call VALUE _stm||_n, _tmp
      end
    end
  end
  drop _stm _size _swp _tmp _n ; return

/* @@PLEAC@@_5.10 */
/* ------------------------------------------------------------------ */
/* If 'merging' is defined as the combining of the contents of two or */
/* more compound variables, then there are no restrictions on the type*/
/* of compound variables that can be merged. Each has to be traversed */
/* and their contents placed into another compound variable, and care */
/* taken in how duplicate keys are handled.                           */
/*                                                                    */
/* If merging has to follow some order then the same restrictions     */
/* applicable to sorting compound variables also applies: NICV's -    */
/* numerically-indexed compound variables - must be used.             */
/* ------------------------------------------------------------------ */

a.key1 = "..." ; a.key2 = "..." ; b.keyX = "..." ; b.keyY = "..."

merge_list = "a. b."

do while merge_list <> NULL
  parse var merge_list hash merge_list
  do while regStemDoOver(hash, 'key')
    merged.key = VALUE(hash||"key")
  end
end

/* ----------------------------- */

key = "Apple" ; food_color.key = "red"
key = "Banana" ; food_color.key = "yellow"
key = "Lemon" ; food_color.key = "yellow"

key = "Galleano" ; drink_color.key = "yellow"
key = "Mai Tai" ; drink_color.key = "blue"

drop substance_color.

merge_list = "food_color. drink_color."

do while merge_list <> NULL
  parse var merge_list hash merge_list
  do while regStemDoOver(hash, 'key')
    substance_color.key = VALUE(hash||"key")
  end
end

/* @@PLEAC@@_5.11 */
/* ------------------------------------------------------------------ */
/* This task is simply a matter of compound variable traversal and key*/
/* existence checking and/or comparison.                              */
/* ------------------------------------------------------------------ */

keys = "k1 k3 k5 k8"
do while keys <> NULL
  parse var keys key keys ; hash1.key = TRUE
end

keys = "k1 k2 k3 k6 k7"
do while keys <> NULL
  parse var keys key keys ; hash2.key = TRUE
end

/* ----------- */

drop common.

do while regStemDoOver('hash1.', 'key')
  if SYMBOL('hash2.key') == 'VAR' then ; common.key = TRUE
end

do while regStemDoOver('common.', 'key')
  say key /* k1, k3 */
end

/* ----------- */

drop this_not_that.

do while regStemDoOver('hash1.', 'key')
  if SYMBOL('hash2.key') \= 'VAR' then ; this_not_that.key = TRUE
end

do while regStemDoOver('this_not_that.', 'key')
  say key /* k5, k8 */
end

/* ----------------------------- */

key = "Apple" ; food_color.key = "red"
key = "Banana" ; food_color.key = "yellow"
key = "Lemon" ; food_color.key = "yellow"

key = "Lemon" ; citrus_color.key = "yellow"
key = "Orange" ; citrus_color.key = "orange"
key = "Lime" ; citrus_color.key = "green"

drop non_citrus.

do while regStemDoOver('food_color.', 'key')
  if SYMBOL('citrus_color.key') \= 'VAR' then ; non_citrus.key = TRUE
end

do while regStemDoOver('non_citrus.', 'key')
  say key /* Apple, Banana */
end

/* @@PLEAC@@_5.12 */
/* ------------------------------------------------------------------ */
/* REXX does not support references; this section is, therefore, not  */
/* applicable. The example using 'files' is, however, implemented to  */
/* illustrate some of REXX's basic file operations.                   */
/* ------------------------------------------------------------------ */

file_list = "/etc/termcap vmunix /bin/cat"

do while file_list <> NULL
  parse var file_list file file_list
  call STREAM file, 'C', 'OPEN READ'
  name.file = TRUE
end

do while regStemDoOver('name.', 'file')
  bytes = STREAM(file, 'C', 'SEEK < READ CHAR')
  say file "is" bytes "bytes long"
  call STREAM file, 'C', 'CLOSE'
end

/* @@PLEAC@@_5.13 */
/* ------------------------------------------------------------------ */
/* Compound variables do not have a 'size', as such. Size is merely a */
/* count of how many leaves exist at a specified time. Thus, size is  */
/* not part of a compound variable's metadata, nor is the concept of  */
/* 'presizing' one that is ordinarily applicable.                     */
/*                                                                    */
/* Of course it is possible to:                                       */
/*                                                                    */
/* * Manually maintain 'size' metadata [e.g. the '.0' leaf in NICV's] */
/*                                                                    */
/* * Add a specified number of leaves to a compound variable, each    */
/*   perhaps containing a value to be interpreted as 'empty'. It is   */
/*   important to note that this can only be performed with NICV's    */
/*   because the key / leaf name must be known in order to add it     */
/* ------------------------------------------------------------------ */

/* 'Pre-size' a numerically-indexed compound variable [NICV] */
hash.0 = required_size

/* Leaves 'hash.1', 'hash.2', through 'hash.required_size' created */
do i = 1 to hash.0
  hash.i = null_value
end

/* ----------------------------- */

/* 'Pre-size' a 512 leaf compound variable */
users.0 = 512

do i = 1 to users.0
  users.i = ""
end

/* ----------- */

/* 'Upsize' to 1000 leaves */
oldsize = users.0 ; users.0 = 1000

do i = oldsize + 1 to users.0
  users.i = ""
end

/* @@PLEAC@@_5.14 */
/* ------------------------------------------------------------------ */
/* Two approaches possible:                                           */
/*                                                                    */
/* * Initialise compound variable leaves to a start value [which makes*/
/*   sure there is always a matching key i.e. a check for existence of*/
/*   leaf / key 'X' is always affirmative]                            */
/*                                                                    */
/* * Check for presence of leaf / key before adding / updating entry  */
/* ------------------------------------------------------------------ */

count. = 0

do while regStemDoOver('array.', 'key')
  element = array.key
  count.element = count.element + 1
end

do while regStemDoOver('count.', 'element')
  say element "=" count.element
end

/* ----------- */

do while regStemDoOver('array.', 'key')
  element = array.key
  if SYMBOL('count.element') == 'VAR' then
    count.element = count.element + 1
  else
    count.element = 0
end

/* @@PLEAC@@_5.15 */
/* ------------------------------------------------------------------ */
/* Relationships can easily be set up through judicious naming of keys*/
/* and compound variable names. The examples in the first part of this*/
/* section exemplify this:                                            */
/*                                                                    */
/*    cv.key ==> father.child ==> father of child is [value]          */
/*                                                                    */
/* Here is a 1:N mapping in which one father has one or more children;*/
/* the 'many' component are keys / leaves, so allowing for traversal  */
/* by children, and the 'one' component extractable via comparision.  */
/*                                                                    */
/* Since keys / leaves must be unique, an inversion of the form:      */
/*                                                                    */
/*    cv.key ==> child.father ==> child of father is [value]          */
/*                                                                    */
/* is not possible since the 'many' component would be lost. However, */
/* if the 'many' component is represented as a string with each new   */
/* item appended, then a mapping of the form:                         */
/*                                                                    */
/*    cv.key ==> children.father ==> children of father are [value]   */
/*                                                                    */
/* is possible.                                                       */
/* ------------------------------------------------------------------ */

key = "Cain" ; father.key = "Adam"
key = "Abel" ; father.key = "Adam"

key = "Seth" ; father.key = "Adam"
key = "Enoch" ; father.key = "Cain"

key = "Irad" ; father.key = "Enoch"
key = "Mehujael" ; father.key = "Irad"

key = "Methusael" ; father.key = "Mehujael"
key = "Lamech" ; father.key = "Methusael"

key = "Jabal" ; father.key = "Lamech"
key = "Jubal" ; father.key = "Lamech"

key = "Tubalcain" ; father.key = "Lamech"
key = "Enos" ; father.key = "Seth"

/* ----------- */

do while LINES() > 0
  father = LINEIN() ; if father == NULL then ; leave
  say father || ":"
  do while regStemDoOver('father.', 'child')
    if father == father.child then ; say "   " child
  end
end

/* ----------------------------- */

/* Flawed inversion of 'father.child' relationship */

do while regStemDoOver('father.', 'child')
  key = father.child ; child.key = child
end

/* 1:N mapping lost; only one child per father */
do while regStemDoOver('child.', 'father')
  say father "begat" child.father
end

/* ----------- */

/* String-based inversion of 'father.child' relationship */

do while regStemDoOver('father.', 'child')
  key = father.child
  if SYMBOL('children.key') == 'VAR' then
    children.key = children.key child
  else
    children.key = child
end

/* 1:N mapping retained */
do while regStemDoOver('children.', 'father')
  if LENGTH(children.father) > 0 then
    list_of_children = CHANGESTR(" ", children.father, ", ")
  else
    list_of_children = "nobody"
  say father "begat" list_of_children
end

/* ----------------------------- */

key = "f1.txt" ; files.key = TRUE ; key = "f2.txt" ; files.key = TRUE

do while regStemDoOver('files.', 'file')
  call STREAM file, 'C', 'OPEN READ'

  do while LINES(file) > 0
    /* 'match' is a REXXToolkit custom function [see Appendix] */
    if match(LINEIN(file), "#include") then ; includes.file = TRUE
  end

  call STREAM file, 'C', 'CLOSE'
end

/* ----------- */

do while regStemDoOver('files.', 'file')
  if SYMBOL('includes.file') \= 'VAR' then ; includes_free.file = TRUE
end

/* @@PLEAC@@_5.16 */
/* ------------------------------------------------------------------ */
/* Program: dutree                                                    */
/* ------------------------------------------------------------------ */

@@INCOMPLETE@@
@@INCOMPLETE@@

/* @@PLEAC@@_7.0 */
/* ------------------------------------------------------------------ */
/* REXX sports, as an ANSI Standard feature, a highly simplified file */
/* I/O model. Features:                                               */
/*                                                                    */
/* * File name is used as the 'handle'                                */
/* * Implicit file opening on first use                               */
/*                                                                    */
/* This model certainly promotes ease-of-use. It is also designed to  */
/* be platform agnostic, so that the same I/O code *should* work on   */
/* widely differing platforms [at least that's the theory ;) !]. On   */
/* the other hand, it:                                                */
/*                                                                    */
/* * Is quite 'alien' to those accustomed to file descriptor-based I/O*/
/*   as found in *NIX / C / Perl/Ruby/Python                          */
/* * Makes it impossible to have multiple 'views' [via multiple handl-*/
/*   es] of the same file, or to redirect I/O within the program [that*/
/*   is, without 'shelling out' or using temporary files]             */
/*                                                                    */
/* Consequently, many of the examples in this chapter are not directly*/
/* implementable in REXX. However, wherever possible, the task will be*/
/* performed with some other approach even if it comes across as some-*/
/* what contrived.                                                    */
/* ------------------------------------------------------------------ */

filename = "data.txt"                    /* ANSI-standard I/O */

/* Explicit OPEN, CLOSE, and stream status check */
if STREAM(filename, 'C', "OPEN READ") == "READY:" then do
  do while LINES(filename) > 0
    line = LINEIN(filename) ; if line == NULL then ; leave
    spos = POS("blue", line)
    if spos > 0 then say SUBSTR(line, spos)
  end
  call STREAM filename, 'C', "CLOSE"
end

/*
   Alternative: implicit OPEN, CLOSE; 'null' check - terminates on
   either EOF or 'empty' line [use 'LINES(...) == 0' check to verify
   EOF]
*/

line = LINEIN(filename)
do while line <> NULL
  spos = POS("blue", line)
  if spos > 0 then say SUBSTR(line, spos)
  line = LINEIN(filename)
end

/* ----------------------------- */

filename = "data.txt" ; fh = "data"      /* AREXX-compatible I/O */

if OPEN(fh, filename, "READ") then do
  line = READLN(fh)
  do until EOF(fh)
    spos = POS("blue", line)
    if spos > 0 then say SUBSTR(line, spos)
    line = READLN(fh)
  end
  call CLOSE fh
end

/* ----------------------------- */

/*
   LINEIN's default stream is "<stdin>", LINEOUT's is "<stdout>";
   'null' check - terminates on either EOF or 'empty' line [use 
   'LINES(...) == 0' check to verify EOF]
*/

line = LINEIN()
do while line <> NULL
  if VERIFY("0123456789", line, 'M') == 0 then
    call LINEOUT "<stderr>", "No digit found"
  call LINEOUT , line
  line = LINEIN() ; if LINES() == 0 then ; leave
end

/* Alternative: STREAM to check stream status, PARSE VALUE LINEIN */

do while STREAM("<stdin>", 'S') \= "NOTREADY"
  parse value LINEIN() with line
  if line <> NULL then do
    if VERIFY("0123456789", line, 'M') == 0 then
      call LINEOUT "<stderr>", "No digit found"
    call LINEOUT , line
  end
end

/* Alternative: Data extracted from STACK - REXX idiomatic */

SYSCMD = 'type data.txt | rxqueue'   /* Platform-specific [Win32] */
'SYSCMD'                             /* Direct data into STACK */

do while QUEUED() > 0
  parse pull line
  if line <> NULL then do
    if VERIFY("0123456789", line, 'M') == 0 then
      call LINEOUT "<stderr>", "No digit found"
    call LINEOUT , line
  end
end

/* ----------------------------- */

call STREAM(logfile, 'C', "OPEN WRITE")

/* ----------------------------- */

call STREAM(logfile, 'C', "CLOSE")

/* ----------------------------- */

/*
   There is no concept of 'default stream' in REXX. The I/O BIF's
   simply assume a default value of either "<stdin>" or "<stdout>"
   when called without an explicit stream argument.
*/

filename = logfile
call LINEOUT filename, "Countdown initiated ..."

filename = originalfile
call LINEOUT filename, "You have 60 seconds to reach minimum safe",
                       "distance ..."

/* @@PLEAC@@_7.1 */
call STREAM path, 'C', 'READ'  /* open file "path" for reading only */
call OPEN alias, path, 'READ'

call STREAM path, 'C', 'WRITE' /* open file "path" for writing only */
call OPEN alias, path, 'WRITE'

call STREAM path, 'C', 'BOTH'  /* open "path" for reading and writing */
call OPEN alias, path, 'WRITE' /* allows both read and write */

/*
   open file "path" write only, create it if it does not exist,
   truncate to zero length if exists
*/
call STREAM path, 'C', 'WRITE REPLACE'

/* open file "path" write only, fails if file exists */
/* Cannot do - must check for file existence and manually fail */

/* open file "path" for appending */
call STREAM path, 'C', 'WRITE APPEND'
call OPEN alias, path, 'APPEND'

/* open file "path" for appending only when file exists */
/* Cannot do - must check for file existence and then take action */

/* open file "path" for reading and writing */
call STREAM path, 'C', 'BOTH'
call OPEN alias, path, 'WRITE' /* allows both read and write */

/* open file for reading and writing, create file if doesn't exist */
call STREAM path, 'C', 'BOTH APPEND'
call OPEN alias, path, 'APPEND' /* allows both read and append */

/* open file "path" reading and writing, fails if file exists */
/* Cannot do - must check for file existence and manually fail */

/* @@PLEAC@@_7.2 */
/* ------------------------------------------------------------------ */
/* REXX has no problem handling files with unusual filenames, thus    */
/* nothing beyond normal file handling need be done.                  */
/* ------------------------------------------------------------------ */

/* *** Translation skipped *** */

/* @@PLEAC@@_7.3 */
/* ------------------------------------------------------------------ */
/* This item is *NIX-specific; code examples reflect this.            */
/*                                                                    */
/* The general approach taken in REXX to such a task is to construct  */
/* a 'command string', that is, a sequence of characters that can be  */
/* sent to the platform's command interpreter [a.k.a. command         */
/* processor or shell] for execution. In most cases generated output  */
/* is captured and used as the 'result' of the command. Depending on  */
/* the platform, too, there may also be an 'command status code'      */
/* available that may be used for diagnostic purposes.                */
/*                                                                    */
/* REXX supports two modes of 'command execution':                    */
/*                                                                    */
/* * Implicit i.e command is passed directly to the default shell     */
/* * Explicit, via the ADDRESS instruction; allows choice of shell,   */
/*   and output handling                                              */
/* ------------------------------------------------------------------ */

filename = "/myfile.dat"

/* ----------------------------- */

/* Implicit Command Execution [output redirected to system STACK] */
'echo ~ >LIFO' ; parse pull expandedTilde

filename = expandedTilde || filename

/* ----------------------------- */

/* Explicit Command Execution (1) [same as previous example] */
address SYSTEM 'echo ~' with OUTPUT LIFO "" ; parse pull expandedTilde

filename = expandedTilde || filename

/* ----------------------------- */

/* Explicit Command Execution (2) [output directed to stem variable] */
address SYSTEM 'echo ~' with OUTPUT STEM expandedTilde.

filename = expandedTilde.1 || filename

/* ----------------------------- */

/* Explicit Command Execution (3) [output directed to file] */
TMPFILE = './exp.$$$' ; DELCMD = 'rm -f' TMPFILE

address SYSTEM 'echo ~' with OUTPUT STREAM TMPFILE

expandedTilde = LINEIN(TMPFILE) ; filename = expandedTilde || filename

address SYSTEM DELCMD

/* @@PLEAC@@_7.4 */
parse source . . sourcefile

/* Trap file I/O conditions */
signal on NOTREADY

filename = "..."
call STREAM filename, 'C', 'OPEN READ'

/* Success */
say filename "was opened ok"
exit 0

/* Open error */
NOTREADY :
  say "In line" SIGL "of source file" sourcefile
  say "a" CONDITION('C') "condition was trapped."
  say "Could not open file" CONDITION('D') "for reading"
  exit 1

/* @@PLEAC@@_7.5 */
/*
   Utilise 'tmpnam' functionality via 'mktemp' utility
*/

tmpnam : procedure expose (globals)
  address SYSTEM 'mktemp' with OUTPUT STEM tmpnam.
  if RC \= 0 then ; tmpnam.1 = NULL
  return tmpnam.1

/* ----------- */

/*
   Use 'rexxUtil's' 'sysTempFileName'
*/

tmpnam : procedure expose (globals)
  tmpnam = "/tmp/" || sysTempFileName('??tmp???')

  if tmpnam \= NULL then do
    call STREAM tmpnam, 'C', 'OPEN WRITE'
    call STREAM tmpnam, 'C', 'CLOSE'
  end

  return tmpnam

/* ----------------------------- */

tmpnam = tmpnam()

if tmpnam == NULL then do
  say "Unable to create temporary file" ; exit 1
end

/* ----------- */

tmpnam = tmpnam()

do while tmpnam <> NULL
  tmpnam = tmpnam()
end

/* ... use file ... */

/* Delete file before exiting program ... */
call sysFileDelete tmpnam

/* ----------- */

tmpnam = tmpnam()

if tmpnam == NULL then do
  say "Unable to create temporary file" ; exit 1
end

do i = 1 for 10
  call CHAROUT tmpnam, i
end

call STREAM tmpnam, 'C', 'SEEK' 1 'READ' 'CHAR'

say "Tmp file has:" LINEIN(tmpnam)

/* @@PLEAC@@_7.6 */
/* Data residing within a comment block */
signal DATA /*
Line 1 ...
Line 2 ...
Line 3 ...
*/

/* Load data into 'data' as a table of lines */
DATA:
  data = NULL
  do i = SIGL + 1
    line = SOURCELINE(i)
    if line = "*/" then leave
    if data == NULL then
      data = line
    else
      data = data || NEWLINE || line
  end

/* Use data */
say data

/* @@PLEAC@@_7.7 */
/* ------------------------------------------------------------------ */
/* STDIN, STDOUT and STDERR are implemented as the 'special' file nam-*/
/* es, "<stdin>", "<stdout>", and "<stderr>", respectively. In additi-*/
/* on, the ANSI Standard I/O routines use the first two of these as   */
/* defaults where a filename is not provided. This, together with the */
/* PARSE instruction, and an extensive set of string manipulation BIFs*/
/* makes the writing of filter programs quite straightforward in REXX.*/
/* ------------------------------------------------------------------ */

/* priming read */
line = LINEIN()

/* terminates on both 'empty' line and EOF - do LINES() check for EOF */
do while line <> NULL
  /* do something with 'line' */
  /* ... */

  /* let's now get another one ... */
  line = LINEIN()
end

/* ----------- */

/* priming read */
line = LINEIN()

/* check for data availability */
do while LINES() > 0

  /* if data was extracted i.e. not an empty line */
  if line <> NULL then do
    /* do something with 'line' */
    /* ... */
  end

  /* let's now get another line ... */
  line = LINEIN()
end

/* ----------- */

/* check for data availability */
do while STREAM("<stdin>", 'S') \= "NOTREADY"

  /* let's now get a line, optionally parsing it into fields ... */
  parse value LINEIN() with line

  /* if data was extracted i.e. not empty fields */
  if line <> NULL then do
    /* do something with 'line' */
    /* ... */
  end
end

/* ----------------------------- */

/* Processing a number of files passed on the command line */

/* No filename arguments, so assume working with STDIN */
if ARG() < 1 then
   call do_with "<stdin>"
else
  /* Process each filename argument in turn */
  do i = 1 for ARG()
    call do_with ARG(i)
  end

exit 0

/* ----------- */

do_with : procedure expose (globals)
  file = ARG(1)

  if STREAM(file, 'C', 'OPEN READ') \= 'READY:' then do
    say "Can't open" file ; return
  end

  line = LINEIN(file)

  do while LINES(file) > 0
    /* do something with line ... */
    say line

    line = LINEIN(file)
  end

  return

/* ----------------------------- */

argv = NULL ; argc = ARG()

/* Either grab file list from command-line, or ... */
if argc > 0 then
  if argc > 1 then
    /* filename(s) as separate argument strings [-a option] */
    do i = 1 for ARG() ; argv = argv ARG(i) ; end
  else
    /* filename(s) as single argument string */
    argv = ARG(1)
else
  /* ... get it yourself */
  argv = glob("*.[cCh]")

argv = STRIP(argv)

/* ----------------------------- */

/*
   The following are 'quickie' solutions matching the Perl examples;
   REXXToolkit has a 'getopt' routine offering functionality similar
   to *NIX 'getopt', and it would be the preferred approach
*/

/* arg demo: 1 [assume Regina '-a' option used] */
if ARG() > 0 & ARG(1) == "-c" then ; chop_first = chop_first + 1

/* ----------- */

/* arg demo: 2 [assume Regina '-a' option used] */
if ARG() > 0 & match(ARG(2), "^-[[:digit:]]+$") then
  parse value ARG(2) with "-" columns .

/* ----------- */

/* arg demo: 3 [assume Regina '-a' option used] */
parse SOURCE . . source

do i = 1 for ARG()
  parse value ARG(i) with "-" option .
  if option == NULL then ; iterate
  if VERIFY("ainu", option, 'M') == 0 then do
    call LINEOUT "<stderr>", "usage:" source "[-ainu] [filenames...]"
    exit 1
  end
  options = options || option
end

append = 0 ; ignore = 0 ; nostdout = 0 ; unbuffer = 0

if POS("a", options) > 0 then ; append = append + 1
if POS("i", options) > 0 then ; ignore = ignore + 1
if POS("n", options) > 0 then ; nostdout = nostdout + 1
if POS("u", options) > 0 then ; unbuffer = unbuffer + 1

/* ----------------------------- */

/* undef $/ not applicable; do following to load entire file */

/* STDIN - doesn't have a 'size', so use arbitrary 'large' value */
file_contents = CHARIN(,, 9999999)

/* Regular file - use actual file size */
file_contents = CHARIN(file,, CHARS(file))

/* ----------------------------- */

line = LINEIN()

do i = 1 while LINES() > 0
  say "-:" || i || ":" || line
  line = LINEIN()
end

/* ----------------------------- */

line = LINEIN()

do while LINES() > 0
  if match(line, "login") then ; say line
  line = LINEIN()
end

/* ----------- */

do while LINES() > 0
  /*
    'parse lower' is Regina-specific. Can otherwise use:
    line = TRANSLATE(line, "abc...", "ABC...")
  */
  parse lower LINEIN line
  if line <> NULL then ; say line
end

/* ----------- */

line = LINEIN() ; chunks = 0

do while LINES() > 0
  if match(line, "^#") then ; iterate
  if match(line, "_     _(DATA|END)_     _") then ; leave
  chunks = chunks + WORDS(line)
  line = LINEIN()
end

say "Found" chunks "chunks"

/* @@PLEAC@@_7.8 */
old = "..." ; new = "..."

/* Explicit file opening optional */
call STREAM old, 'C', 'OPEN READ' ; call STREAM new, 'C', 'OPEN WRITE'

/* Priming read */
line = LINEIN(old)

do while LINES(old) > 0
  if line <> NULL then do
    /* Change line ... */
    line = line || 3
  end ; else do
    /* Handle 'empty' line */
    nop
  end

  /* Write it to new */
  call LINEOUT new, line

  /* Get another line */
  line = LINEIN(old)
end

call STREAM old, 'C', 'CLOSE' ; call STREAM new, 'C', 'CLOSE'

call sysMoveObject old, "old.orig" ; call sysMoveObject new, old
call sysFileDelete "old.orig"

/* ----------------------------- */

/* ... */

line = LINEIN(old)

do while LINES(old) > 0
  if STREAM(old, 'C', 'QUERY SEEK READ LINE') == 20 then do
    call LINEOUT new, "Extra line 1 ..."
    call LINEOUT new, "Extra line 2 ..."
  end

  call LINEOUT new, line

  line = LINEIN(old)
end

/* ... */

/* ----------- */

/* ... */

line = LINEIN(old)

do while LINES(old) > 0
  line_number = STREAM(old, 'C', 'QUERY SEEK READ LINE')
  if line_number >= 20 & line_number <= 30  then ; iterate

  call LINEOUT new, line

  line = LINEIN(old)
end

/* ... */

/* @@PLEAC@@_7.9 */
/* ------------------------------------------------------------------ */
/* AFAIK, no REXX interpreter has an '-i' switch to force in-place    */
/* modification of files. The file modification has to be programmed  */
/* in, and it is this approach that will be used here.                */
/* ------------------------------------------------------------------ */

/*
   In-place modification not possible since replacement is not the
   same size. The 1st command-line is assumed to be the file name
*/

file = ARG(1) ; tmpnam = tmpnam()

call STREAM file, 'C', 'OPEN READ'
call STREAM tmpnam, 'C', 'OPEN WRITE'

/* Use REXXToolkit's 'strftime' */
today = strftime("+%Y-%m-%d", makeYMD()) ; line = LINEIN(file)

do while LINES(file) > 0
  line = subst("DATE", line, today) ; call LINEOUT tmpnam,, line
  line = LINEIN(file)
end

call STREAM file, 'C', 'CLOSE' ; call STREAM tmpnam, 'C', 'CLOSE'

call sysMoveObject file, "file.orig" ; call sysMoveObject tmpnam, file
call sysFileDelete "file.orig"

/* @@PLEAC@@_7.10 */
/* ------------------------------------------------------------------ */
/* While it's possible, using the ANSI Standard I/O routines, to alter*/
/* the contents of a file in-place, including appending additional da-*/
/* ta, it isn't possible to truncate the file. Therefore, in order to */
/* ensure file intergrity is maintained [i.e. file contains only any  */
/* necessary (not extraneous) data], a new file should be created, and*/
/* necessary data copied into it. Of course, this could be done as a  */
/* later step - in the interim, the extraneous data could be overwrit-*/
/* ten with some arbitrary value marking it as such. Messy, yes, but  */
/* doable :) !                                                        */
/* ------------------------------------------------------------------ */

/* [1] In-place modification of same-or-greater-length data */

file = "..."

call STREAM file, 'C', 'OPEN BOTH'

/* Move write pointer to start of file */
call STREAM file, 'C', 'SEEK' '1' 'WRITE' 'CHAR'

/* Locate and read required data */
data = CHARIN(file, some_offset, some_amount)

/* Do something to data ... */
data = ...

/* Write it back out, in-place, exactly replacing old data */
call CHAROUT file, some_offset, data

call STREAM file 'C', 'CLOSE'

/* ----------- */

/*
   [2] In-place modification of less-length data - file contents
   [bar the 'padded' items] should later be copied to a new file
*/

file = "..."

call STREAM file, 'C', 'OPEN BOTH'

/* Record initial size of file */
bytes = CHARS(file)

/* Move write pointer to start of file */
call STREAM file, 'C', 'SEEK' '1' 'WRITE' 'CHAR'

/* Locate and read required data */
data = CHARIN(file, some_offset, some_amount)

/* Do something to data ... */
data = ...

/* Write it back out partly replacing old data */
call CHAROUT file, some_offset, data

/* Pad out rest of file with arbitrary byte value */
call CHAROUT file, (some_offset + LENGTH(data)), D2C(0)

call STREAM file 'C', 'CLOSE'

/* ----------------------------- */

/* Preferred approach - copy data to new file then rename / delete */
old = "..." ; new = "..."

call STREAM old, 'C', 'OPEN READ' ; call STREAM new, 'C', 'OPEN WRITE'

/* Read, process, and write new data to new file */
/* ... */

call STREAM old, 'C', 'CLOSE' ; call STREAM new, 'C', 'CLOSE'

call sysMoveObject old, "old.orig" ; call sysMoveObject new, old
call sysFileDelete "old.orig"

/* @@PLEAC@@_7.11 */
/* ------------------------------------------------------------------ */
/* The ANSI Standard I/O BIF's, STREAM, LINE[IN|OUT], CHAR[IN|OUT],   */
/* don't implement file locking: a file may be opened by multiple     */
/* scripts for both read and write access, and there is no means of   */
/* specifiying, for example, that exclusive file access is needed.    */
/*                                                                    */
/* Where synchronised file update is required, say in updating a shar-*/
/* ed log file, the choice is to:                                     */
/*                                                                    */
/* * Use low-level routines that offer file locking [e.g. via library */
/*   or (Regina-only) GCI facility]                                   */
/* * Use an inter-process mutual exclusion mechanism [e.g. process th-*/
/*   at needs to write to the file acquires exclusive access (no other*/
/*   process can open the file for any purpose until it is released), */
/*   then releases it when done]                                      */
/* * Use some other inter-process signaling mechanism [e.g. access is */
/*   available to all processes, and any process that updates the file*/
/*   (e.g. appends to it) signals that the file has been updated. The */
/*   other processes will, on next attempt to use the file detect its */
/*   'status' change, so will close and reopen it, thus 'refreshing'  */
/*   their view of the file]                                          */
/*                                                                    */
/* The latter two approaches are possible via the mutex and event sem-*/
/* aphore facilities of the 'rexxUtil library. However, only an examp-*/
/* le of the former will be shown here.                               */
/* ------------------------------------------------------------------ */

/*
   Canonical example of mutex semaphore use in REXX ['rexxUtil'
   library] an approach that can be applied to ensure a process
   has exclusive access to a file. However, in order for this
   to work reliably all processes must follow the same protocol:

   - acquire lock
   - use file, then close
   - release lock

   Disadvantage is that only one process can use the file at any
   one time regardless of whether it is a read or update operation
*/

/* Attempt to acquire handle to existing semaphore */
sem = sysOpenMutexSem("SEMNAME")

/* If failed, then no semaphore exists, so create one */
if sem == 0 then ; sem = sysCreateMutexSem("SEMNAME")

timeout = 3000 /* ms */

/* Attempt to acquire exclusive access to resource */
if sysRequestMutexSem(sem, timeout) == 0 then do

  /* Ok, resource is acquired; so something with it */
  /* ... */

  /* All done with resource, so release it */
  call sysReleaseMutexSem sem

end ; else do

  /* Could not acquire resource - locked by other process */
  /* ... */

end

/* Close handle to semaphore - last 'close' will destroy it */
call sysCloseMutexSem sem

/* ----------------------------- */

/*
   Implementations of Perl examples
*/

/* ... prologue code omitted ... */

numfile = "..." ; timeout = 2

if sysRequestMutexSem(sem) \= 0 then do
  say "Cannot immediately write-lock the file" numfile "blocking..."
  call sysSleep timeout

  if sysRequestMutexSem(sem) \= 0 then do
    say "Can't get write-lock on" numfile
  end ; else do
    /* ... do something with 'numfile' ... */

    /* All done ... release lock */
    call sysReleaseMutexSem sem
  end
end ; else do
  /* ... do something with 'numfile' ... */

  /* All done ... release lock */
  call sysReleaseMutexSem sem
end

/* ----------- */

/* Can't implement 'select' example */

/* ----------- */

/* ... prologue code omitted ... */

numfile = "..." ; timeout = 2

if sysRequestMutexSem(sem) \= 0 then do
  say "Cannot write-lock the file" numfile "exiting ..."
  exit 1
end

if STREAM(numfile, 'C', 'OPEN BOTH') \= "READY:" then do
  say "Cannot open the file" numfile "exiting..."
  exit 1
end

/* ... do stuff with 'numfile' ... */

/* Close file and release semaphore */
call STREAM numfile, 'C', 'CLOSE' ; call sysReleaseMutexSem sem

/* @@PLEAC@@_7.12 */
/* ------------------------------------------------------------------ */
/* There is, in the ANSI Standard I/O routines, no user control over  */
/* file buffering - it is all handled internally - thus most of the   */
/* examples in this section are not implementable.                    */
/* ------------------------------------------------------------------ */

/* It *is* possible to flush any file, including STDOUT */
call STREAM "<stdout>", 'C', 'FLUSH'

/* ----------------------------- */

/*
   See PLEAC 18 for examples of socket-based code
*/

/* @@PLEAC@@_7.13 */
/* ------------------------------------------------------------------ */
/* No such functionality is available natively in REXX. However, it   */
/* might be possible to use Regina's GCI facility to make available   */
/* the *NIX 'select' function [and any support functions it may need] */
/* in order to perform this task.                                     */
/* ------------------------------------------------------------------ */

@@INCOMPLETE@@
@@INCOMPLETE@@

/* @@PLEAC@@_7.14 */
/* ------------------------------------------------------------------ */
/* No such functionality is available natively in REXX. However, it   */
/* might be possible to use Regina's GCI facility to make available   */
/* the *NIX 'fcntl' function [and any support functions it may need]  */
/* in order to perform this task.                                     */
/* ------------------------------------------------------------------ */

@@INCOMPLETE@@
@@INCOMPLETE@@

/* @@PLEAC@@_7.15 */
/* ------------------------------------------------------------------ */
/* The number of bytes in a file may be determined:                   */
/*                                                                    */
/* * Via the 'STREAM' BIF [which probably uses 'ioctl' on *NIX]       */
/* * Via the 'CHARS' BIF                                              */
/* * Opening the file, and seeking to the end                         */
/* ------------------------------------------------------------------ */

file = "..."

say "File" file "is" STREAM(file, 'C', 'QUERY SIZE') "bytes in size."

/* ----------------------------- */

file = "..."

call STREAM file, 'C', 'OPEN READ' ; bytes = CHARS(file)
call STREAM file, 'C', 'CLOSE'

say "File" file "is" bytes "bytes in size."

/* ----------------------------- */

file = "..."

call STREAM file, 'C', 'OPEN READ'
call STREAM file, 'C', 'SEEK' '<0' 'READ' 'CHAR'

bytes = STREAM(file, 'C', 'QUERY SEEK READ CHAR')

call STREAM file, 'C', 'CLOSE'

say "File" file "is" bytes "bytes in size."

/* @@PLEAC@@_7.16 */
/* ------------------------------------------------------------------ */
/* REXX, through its ANSI Standard I/O functions, does not support fi-*/
/* le descriptor-based I/O; instead, the file name is used as the han-*/
/* dle. However, it is possible to query an open file's handle, though*/
/* this is of little practical use unless a library of low-level rout-*/
/* ines allowing file handle manipulation, is used. Thus, most of the */
/* code in this section is not implementable.                         */
/* ------------------------------------------------------------------ */

filename = "..."

/* Store file handle in a variable */
variable = STREAM(filename, 'C', 'QUERY HANDLE')

/* Pass file handle as argument to subroutine */
call subroutine STREAM(filename, 'C', 'QUERY HANDLE'), filename

/* ----------- */

subroutine : procedure
  fh = ARG(1) ; filename = ARG(2)
  say "File handle for file" filename "is" fh
  return

/* ----------------------------- */

/* Should display 0, 1, 2, respectively, the 'standard' I/O handles */
say STREAM("<stdin>", 'C', 'QUERY HANDLE')
say STREAM("<stdout>", 'C', 'QUERY HANDLE')
say STREAM("<stderr>", 'C', 'QUERY HANDLE')

/* @@PLEAC@@_7.17 */
/* ------------------------------------------------------------------ */
/* REXX, through its ANSI Standard I/O functions, does not support fi-*/
/* le descriptor-based I/O; instead, the file name is used as the han-*/
/* dle. Therefore, the task of caching 'open file handles' is not app-*/
/* licable. Thus, the code in this section is not implementable.      */
/* ------------------------------------------------------------------ */

/* *** Translation skipped *** */

/* @@PLEAC@@_7.18 */
/* ------------------------------------------------------------------ */
/* REXX, through its ANSI Standard I/O functions, does not support fi-*/
/* le descriptor-based I/O. Some of the tasks in this section may be  */
/* performed by substituting file names for file descriptors, whilst  */
/* those involving shell invocation may be performed by constructing  */
/* a command string, and passing it to the ADDRESS instruction for ex-*/
/* ecution.                                                           */
/* ------------------------------------------------------------------ */

filenames = "a.txt b.txt c.txt" ; stuff_to_print = "..."

do while filenames <> NULL
  parse var filenames file filenames
  call LINEOUT file, stuff_to_print
end

/* ----------------------------- */

/* Generate data file */
datain = "..."
call LINEOUT datain, "..."

/* Output file names */
f1 = "..." ; f2 = "..." ; f3 = "..."

/* Build command string - redirects data to several files */
cmd = "tee" f1 f2 f3

/*
   Execute command string through the shell, with data
   directed to STDOUT, and 'tee'd to the output files
*/
address SYSTEM cmd with INPUT STREAM datain,
                        OUTPUT STREAM "<stdout>"

/* Delete the input data file */
call sysFileDelete datain

/* @@PLEAC@@_7.19 */
/* ------------------------------------------------------------------ */
/* REXX, through its ANSI Standard I/O functions, does not support fi-*/
/* le descriptor-based I/O, thus most of the examples in this section */
/* cannot be implemented.                                             */
/*                                                                    */
/* The only descriptor-based task that may be performed is the use of */
/* the 'STREAM' BIF to query the file descriptor of currently-open    */
/* file [example shown below]. It is, of course, possible to pass this*/
/* information on to a shell script [invoked via the ADDRESS instruct-*/
/* ion], but this would merely be a, probably useless, contrivance.   */
/* ------------------------------------------------------------------ */

/* Open the file */
call STREAM file, 'C', 'OPEN READ'

/* Print file descriptor of this open file */
say STREAM(file, 'C', 'QUERY HANDLE')

/* Close the file */
call STREAM file, 'C', 'CLOSE'

/* Print [invalid] file descriptor of this, now-closed, file */
say STREAM(file, 'C', 'QUERY HANDLE')

/* @@PLEAC@@_7.20 */
/* ------------------------------------------------------------------ */
/* REXX, through its ANSI Standard I/O functions, does not support fi-*/
/* le descriptor-based I/O, thus the notion of copying file handles is*/
/* moot. However, whilst STDIN, STDOUT, and STDERR cannot be directly */
/* altered, they can be temporarily mapped to files within the context*/
/* of the ADDRESS instruction [an example is shown below].            */
/* ------------------------------------------------------------------ */

RANDOMCMD = "cat" /* Platform-specific [*NIX] */

INFILE = "program.in" ; OUTFILE = "program.out"

/* Redirect command output */
address path RANDOMCMD with input STREAM INFILE,
                            output STREAM OUTFILE,
                            error STREAM "<stdout>"

/* Reset redirected streams to default values */
address path with input NORMAL output NORMAL error NORMAL

/* @@PLEAC@@_7.21 */
/* ------------------------------------------------------------------ */
/* Program: netlock                                                   */
/* ------------------------------------------------------------------ */

@@INCOMPLETE@@
@@INCOMPLETE@@

/* @@PLEAC@@_7.22 */
/* ------------------------------------------------------------------ */
/* Program: lockarea                                                  */
/* ------------------------------------------------------------------ */

@@INCOMPLETE@@
@@INCOMPLETE@@


/* @@PLEAC@@_9.0 */
/* ------------------------------------------------------------------ */
/* Directories, that is, files which contain other files, is a concept*/
/* unique to hierarchical file systems, something not universally     */
/* implemented, most notably, in early versions of VM/CMS and MVS/TSO,*/
/* notable mainframe operating systems, as well as desktop computer   */
/* systems like CP/M. Though this is probably of little interest to   */
/* most, it is mentioned because one of REXX's strengths is its true  */
/* cross-platform operability [that is, across widely varying OS, not */
/* *NIX variants and Win32 :) !]. The code examples shown here are not*/
/* cross-platform but strongly tied to the *NIX environment in keep-  */
/* with the Perl Cookbook's *NIX orientation.                         */
/*                                                                    */
/* Also, this section makes extensive use of both the 'rexxUtil' and  */
/* 'rexxRe' libraries; scripts using this code will need to include   */
/* the following at the start of the sript:                           */
/*                                                                    */
/*   call rxFuncAdd 'sysLoadFuncs', 'rexxUtil', 'sysLoadFuncs'        */
/*   call sysLoadFuncs                                                */
/*   call rxFuncAdd 'reLoadFuncs', 'rexxRE', 'reLoadFuncs'            */
/*   call reLoadFuncs                                                 */
/*                                                                    */
/* and at the end:                                                    */
/*                                                                    */
/*   call reDropFuncs                                                 */
/*   call sysDropFuncs                                                */
/* ------------------------------------------------------------------ */

/*
   *NIX-specific approach: 'stat' utility

   Rename 'entry' to 'statinfo', a compound variable; leaf '.1' is a
   string containing:

     filename filetype size access modification change

   Other data may be obtained by altering value of 'statflds'
*/

filename = "/usr/bin/vi"
statflds = "%n %F %s %x %y %z" ; cmd = "stat --format '" ||,
            statflds || "'"

address SYSTEM cmd filename with OUTPUT STEM statinfo.

if RC \= 0 then do
  say "Couldn't 'stat' " filename ":" RC ; exit RC
end ; else do
  /* Parse and display data */
  parse var statinfo.1 filename filetype filesize atime mtime ctime
  say "Filname:     " filename
  say "Type of file:" filetype
  /* ... */
end

/* ----------- */

/*
   Regina-only: also possible to utilise GCI facility to directly invoke
   the 'stat' C library function. This could be wrapped up in a native
   REXX function, as shown:

     UNIXstat : procedure expose (globals)
       filename = ARG(1) ; statinfo = NULL

       ... setup 'stat' with GCI ...
       ... invoke 'stat' ...
       ... parse and reformat 'stat'-returned data ...

       return statinfo

   GCI implementations of both, 'stat' and 'utime', appear in the
   Appendix
*/

filename = "/usr/bin" ; entry = UNIXstat(filename)

if entry == NULL then do
  say "Couldn't 'stat' " filename ":" 1 ; exit 1
end ; else do
  /* Parse and display data */
  parse var entry filename filetype filesize atime mtime ctime
  say "Filname:     " filename
  say "Type of file:" filetype
  /* ... */
end

/* ----------------------------- */

/*
   A more cross-platform [though with some Regina-specific options]
   approach using 'STREAM' BIF. Note more data is obtainable but
   not used in example, and only the modification time [not the
   status change / revision time] obtainable in this manner
*/

parse value STREAM(filename, 'C', 'FSTAT') with . . . . . . filesize

parse value STREAM(filename, 'C', 'QUERY SIZE'),
            STREAM(filename, 'C', 'QUERY TIMESTAMP'),
            with filesize mtime

/* ----------------------------- */

if STREAM(filename, 'C', 'OPEN READ') \= "READY:" then
  say "Error opening" filename

/* ----------- */

/*
   It is not possible to determine whether a file / stream has been
   opened in 'text' or 'binary' mode, merely whether it contains
   data or not. If needed, the stream can be read and checks for
   the platform's 'line terminator' characters [usually CR, LF or
   CRLF] made
*/

if STREAM(filename, 'C', 'QUERY SIZE') == 0 then
  say filename "does not have data in it"

/* ----------------------------- */

/*
   Hierarchical filesystem support cannot be assumed to exist on all
   platforms [though with the widespread adoption of *NIX or *NIX-based
   concepts on various platforms e.g. z/OS UNIX Sytem Services, Mac
   OSX, this is not as true as in the past].

   For 'directory traversal' tasks it is common to see use made of the
   'rexxUtil' library's, 'sysFileTree', routine
*/

dirname = "/usr/bin"

if sysFileTree(dirname||"/", 'dirtree.', 'fso') \= 0 then do
  say "Couldn't open" dirname ":" 1 ; exit 1
end ; else do
  do i = 1 to dirtree.0
    say "Inside" dirname "is something called" dirtree.i
  end
end

/* @@PLEAC@@_9.1 */
/* ------------------------------------------------------------------ */
/* Several library routines exist for querying file timestamps:       */
/*                                                                    */
/* * STREAM BIF                                                       */
/* * RexxUtil library's: sysGetFileDateTime [mtime, ctime only]       */
/*                       sysSetFileDateTime [mtime only]              */
/*                                                                    */
/* but there is no support for modifying timestamps, where one has to */
/* resort to:                                                         */
/*                                                                    */
/* * Invoking [via ADDRESS SYSTEM] a utility such as 'touch'          */
/* * Binding to a C library function such as 'stat' or 'utime' via an */
/*   interpreter-specific mechanism [such as Regina's GCI]            */
/*                                                                    */
/* The 'UNIXstat' and 'UNIXutime' routines used below [code included  */
/* in the Appendix] are examples of the latter.                       */
/* ------------------------------------------------------------------ */

/* Update both access and modification time */
parse value UNIXstat(filename) with . . . READTIME WRITETIME .
call UNIXutime NEWREADTIME, NEWWRITETIME, filename

/* ----------------------------- */

SECONDS_PER_DAY = 60 * 60 * 24

parse value UNIXstat(file) with . . . atime mtime .
parse value (atime - 7 * SECONDS_PER_DAY) (mtime - 7 * SECONDS_PER_DAY),
            with atime mtime

if \UNIXutime(atime, mtime, file) then do
  say "couldn't backdate" file "by a week w/ utime" ; exit 1
end

/* ----------------------------- */

/* Update access time only */
parse value UNIXstat(filename) with . . . . mtime .
call UNIXutime TIME('T'), mtime, file

/* ----------------------------- */

/* uvi - vi a file without changing its access times */
if ARG() < 1 then do ; say "usage: uvi filename" ; exit 1 ; end ; file =
ARG(1)

editor = VALUE("EDITOR",, SYSTEM)
if editor == NULL then ; editor = "vi"
address SYSTEM editor file

if \UNIXutime(atime, mtime, file) then do
  say "couldn't restore" file "to orig times" ; exit 1
end

exit 0

/* @@PLEAC@@_9.2 */
/*
   Cross platform approach using 'rexxUtil' library's, 'sysFileDelete',
   routine. Whilst a zero return code indicates success, a non-zero
   return code [actual value is platform-dependant] indicates the type
   of problem encountered e.g. not found, still in use, etc
*/

call sysFileDelete FILENAME

if RESULT \= 0 then do
  say "Can't delete" FILENAME ":" RESULT ; exit RESULT
end

/* ----------------------------- */

FILENAMES = "f1 f2 f3 ..." ; allFilesDeleted = TRUE

do while FILENAMES <> NULL
  parse var FILENAMES FILE FILENAMES
  call sysFileDelete FILE ; if RESULT then ; allFilesDeleted = FALSE
end

if \allFilesDeleted then do
  say "Couldn't delete all of" FILENAMES ":" 1 ; exit 1
end

/* ----------------------------- */

filelist = "f1 f2 f3 ..." ; totfiles = WORDS(filelist)
count = totfiles

do while filelist <> NULL
  parse var filelist file filelist
  call sysFileDelete file ; if RESULT then ; count = count - 1
end

if count \= totfiles then
  say "Could only delete" count "of" totfiles "files"

/* @@PLEAC@@_9.3 */
/*
   Cross platform approach using 'rexxUtil' library's, 'sysCopyObject',
   routine. Whilst a zero return code indicates success, a non-zero
   return code [actual value is platform-dependant] indicates the type
   of problem encountered e.g. not found, still in use, etc
*/

call sysCopyObject oldfile, newfile

if RESULT \= 0 then do
  say "Can't copy" oldfile "to" newfile ":" RESULT ; exit RESULT
end

/* ----------------------------- */

/*
   File copy effected by copying contents of an existing file to
   a newly-created file. Note: implict opening of file(s), and optional
   closing
*/

IN = 'oldfile' ; OUT = 'newfile' ; BUFSIZE = 256

do while CHARS(IN) > 0
  char = CHARIN(IN,, BUFSIZE) ; if char <> NULL then ; call CHAROUT OUT,
char
end

/* ----------------------------- */

/*
   Command-line utilities may easily be used for this task, but it is
   important to consider how any output [i.e. stdout, stderr] will
   be handled, and whether return codes are significant and whether
   they should be checked.
*/

/* *NIX */
dev = "/dev/null" ; cmd = "cp -pvd" oldfile newfile
address SYSTEM cmd with OUTPUT STREAM dev ERROR STREAM dev
if RC \= 0 then ; say "Error ..."

/* OpenVMS */
dev = "NL:" ; cmd = "copy" oldfile newfile
address SYSTEM cmd with OUTPUT STREAM dev ERROR STREAM dev
if RC \= 1 then ; say "Error ..."

/* Win32 [Return codes unreliable, so best parse output for command
   status]
*/
dev = "NUL:" ; cmd = "copy/v/b/y" oldfile newfile
address SYSTEM cmd with OUTPUT STEM result. ERROR STREAM dev
parse var result.1 numberCopied .
if numberCopied \= 1 then ; say "Error ..."

/* ----------------------------- */

/*
   Copies contents of source file to newly-created / truncated target
   file
*/

call sysCopyObject "datafile.dat", "datafile.bak"

if RESULT \= 0 then do
  say "copy failed:" RESULT ; exit RESULT
end

/* ----------- */

/*
   Adjusts behaviour to either rename source file to target file [if
   they reside on the same device], or creates a new target file and
   copies contents of source file into it
*/

call sysMoveObject "datafile.new", "datafile.dat"

if RESULT \= 0 then do
  say "move failed:" RESULT ; exit RESULT
end

/* @@PLEAC@@_9.4 */
/* ------------------------------------------------------------------ */
/* I'm not entirely sure what the code in this section is meant to do */
/* but I've proceeded on the assumption that, for a group of filenames*/
/* it is loading the corresponding device / inode pairs into a hash   */
/* using those pairs as an alternate identifier for each file.        */
/* ------------------------------------------------------------------ */

do_my_thing : procedure expose (globals) seen.
  filename = ARG(1) ; key = makeDeviceInodePair(filename)
  if SYMBOL('seen.key') \= 'VAR' then do
    /* Do something with 'filename' since not previously seen */
    nop
  end
  return

/* ----------------------------- */

files = "..."

drop seen. keys. ; i = 0

do while files <> NULL
  parse var files file files
  key = makeDeviceInodePair(file)
  /* Either add a new entry or append to exisitng entry */
  if SYMBOL('seen.key') \= 'VAR' then do
    seen.key = file ; i = i + 1 ; keys.i = key
  end ; else ; seen.key = seen.key file
end

keys.0 = i

/* Sort keys */
call sysStemSort 'keys.', 'ascending'

/* Traverse in sorted key order */
do i = 1 for keys.0
  key = keys.i

  /* 'files' is a list of 1 or more filenames */
  files = seen.key

  do while files <> NULL
    parse var files file files
    /* Do something with each filename ... */
  end
end

exit 0

/* ----------- */

makeDeviceInodePair : procedure expose (globals)
  /* Could have used 'UNIXstat' custom function to do this */
  cmd = "stat --format '%D %i'"
  address SYSTEM cmd ARG(1) with OUTPUT STEM devinode.
  if RC \= 0 then ; return NULL
  return devinode.1

/* @@PLEAC@@_9.5 */
/* ------------------------------------------------------------------ */
/* Directory traversal is typically performed using the 'rexxUtil'    */
/* library's, 'sysFileTree', routine. Whilst it's full capabilities   */
/* are not illustrated here, it is possible to generate lists of only */
/* files, only directories, or both, as well as the entire tree from  */
/* the specified location; path can be a fully qualified name or a    */
/* glob [e.g. *.*].                                                   */
/* ------------------------------------------------------------------ */

dirname = "/tmp"

/* Directory names must with the path separator character */
if sysFileTree(dirname||"/", 'files.', 'fo') \= 0 then
  say "Can't open directory" dirname

/* Traverse file list */
do i = 1 to files.0
  /* Do something with each file, accessed as: 'files.i' ... */
end

/* ----------------------------- */

dirname = "/tmp"

say "text files in" dirname "are:"

if sysFileTree(dirname||"/", 'files.', 'fo') \= 0 then
  say "Can't open directory" dirname

/* Traverse file list selecting only text files */
do i = 1 to files.0
  if isTextFile(files.i) then say files.i
end

/* ----------- */

isTextFile : procedure expose (globals)
  /* No standard BIF for this task, so use 'file' utility [*NIX-only] */
  cmd = "file -bN"
  address SYSTEM cmd ARG(1) with OUTPUT STEM filetype.
  if RC \= 0 then ; return FALSE
  return filetype.1 == "ASCII text"

/* ----------------------------- */

/* '.' and '..' don't show up in 'sysFileTree' generated lists */

/* ----------------------------- */

plainFiles : procedure expose (globals)
  dirname = ARG(1) ; filelist = NULL

  /*
     Generated file list:
     - files only, via 'fo' option
     - automatically exclude '.' and '..'
  */
  if sysFileTree(dirname||"/", 'files.', 'fo') \= 0 then do
    say "Can't open directory" dirname ; exit 1
  end

  /* Sort stem */
  call sysStemSort 'files.', 'ascending'

  /*
     Traverse sorted file list, and generate list of only 'regular'
     files
  */
  do i = 1 to files.0
    if isRegularFile(files.i) then ; filelist = filelist files.i
  end

  return STRIP(filelist)

/* ----------- */

isRegularFile : procedure expose (globals)
  fstatinfo = STREAM(ARG(1), 'C', 'FSTAT')
  return WORD(fstatinfo, WORDS(fstatinfo)) == "RegularFile"

/* @@PLEAC@@_9.6 */
/* ------------------------------------------------------------------ */
/* Filtering a list of files is performed via globbing [use made of   */
/* the 'glob' system function, either directly, via a custom function */
/* which itself uses it ('sysFileTree'), or by invoking the shell (a  */
/* simple trick is to issue an 'echo PATTERN' command), or by applying*/
/* regex patterns to a list of files.                                 */
/*                                                                    */
/* Whilst the Perl examples illustrate several variations of this bas-*/
/* ic approach, the present code will only make use of two custom fun-*/
/* ctions, 'glob' and 'grep', both of which may be found in the Appen-*/
/* dix. As the names imply, 'glob' uses 'glob' functionality via the  */
/* 'sysFileTree' utility routine, and 'grep' utlises the regex routine*/
/* in the 'rexxRE' library.                                           */
/* ------------------------------------------------------------------ */

list = glob("*.c")

/* ----------- */

files = grep("\.c$", glob(path, 'NAME'))

/* ----------------------------- */

files = grep("\.[cChH]$", glob(path, 'NAME'))

/* ----------------------------- */

dirname = "/tmp" ; files = NULL

if sysFileTree(dirname||"/", 'files.', 'fo') \= 0 then
  say "Can't open directory" dirname

/* Traverse file list, and generate list of only 'text' files */
do i = 1 to files.0
  if isTextFile(files.i) then ; files = files files.i
end

files = STRIP(files)

/* ----------- */

isTextFile : procedure expose (globals)
  /* No standard BIF for this task, so use 'file' utility [*NIX-only] */
  cmd = "file -bN"
  address SYSTEM cmd ARG(1) with OUTPUT STEM filetype.
  if RC \= 0 then ; return FALSE
  return filetype.1 == "ASCII text"

/* ----------------------------- */

dirname = "/tmp" ; dirs = NULL

/* Extract subdirectories only */
if sysFileTree(dirname||"/", 'dirs.', 'do') \= 0 then
  say "Can't open directory" dirname

/* Traverse subdirectory building list of subdirectory names */
do i = 1 to dirs.0
  dirs = dirs extractPathComponent(dirs.i, 'NAME')
end

/* Include only numerics in final list */
dirs = grep("^[[:digit:]].*$", STRIP(dirs))

/* @@PLEAC@@_9.7 */
/* ------------------------------------------------------------------ */
/* This section mainly illustrates various uses of the 'sysFileTree'  */
/* 'sysFileTree' routine, the rough equivalent in functionality of    */
/* Perl's 'File::Find' module.                                        */
/* ------------------------------------------------------------------ */

dirlist = "..."

do while dirlist <> NULL
  parse var dirlist dir dirlist
  /*
     'processFiles' implemented in next section - applies 'file_proc'
     to each file
  */
  call processFiles dir "file_proc"
end

/* ----------- */

file_proc : procedure expose (globals)
  file = ARG(1)
  /* ... do something to file ... */
  return

/* ----------------------------- */

dirname = "." ; if ARG(1, 'E') then ; dirname = ARG(1)

if sysFileTree(dirname||"/", 'filetree.', 'dso') \= 0 then
  say "Can't open directory" dirname

/* Traverse file tree ... */
do i = 1 to filetree.0
  say filetree.i || "/"
end

/* ----------------------------- */

dirname = "." ; if ARG(1, 'E') then ; dirname = ARG(1)

dirsize = 0

if sysFileTree(dirname||"/", 'filetree.', 'fso') \= 0 then
  say "Can't open directory" dirname

/* Traverse file tree ... */
do i = 1 to filetree.0
  dirsize = dirsize + getFileSize(filetree.i)
end

say dirname "contains" dirsize "bytes"

/* ----------- */

getFileSize : procedure expose (globals)
  fstatinfo = STREAM(ARG(1), 'C', 'FSTAT')
  return WORD(fstatinfo, WORDS(fstatinfo) - 1)

/* ----------------------------- */

/*
   fdirs - find all directories
*/

/* [1] - 'sysFileTree' reports only directories */
dirname = "." ; if ARG(1, 'E') then ; dirname = ARG(1)

if sysFileTree(dirname||"/", 'filetree.', 'dso') \= 0 then
  say "Can't open directory" dirname

/* Traverse file tree ... */
do i = 1 to filetree.0
  say filetree.i
end

/* ----------- */

/*
   [2] - 'sysFileTree' reports both files and directories; filter
   directories out manually
*/
dirname = "." ; if ARG(1, 'E') then ; dirname = ARG(1)

if sysFileTree(dirname||"/", 'filetree.', 'bso') \= 0 then
  say "Can't open directory" dirname

/* Traverse file tree ... */
do i = 1 to filetree.0
  if isDirectory(filetree.i) then ; say filetree.i
end

/* ----------- */

isDirectory : procedure expose (globals)
  fstatinfo = STREAM(ARG(1), 'C', 'FSTAT')
  return WORD(fstatinfo, WORDS(fstatinfo)) == "Directory"

/* @@PLEAC@@_9.8 */
/* ------------------------------------------------------------------ */
/* This section utilises techniques earlier illustrated [use of the   */
/* 'sysFileTree' routine, and custom functions 'glob' and 'grep']. Key*/
/* difference here is that directory traversal is packaged into two   */
/* custom functions ['processDirectories' and 'processFiles'] and use */
/* of the 'interpret' instruction is made to apply functions to each  */
/* directory / file [like a 'foreach' routine on a list or string].   */
/* ------------------------------------------------------------------ */

/* rmtree1 - remove whole directory trees like rm -r */
if ARG() < 1 then do ; say "usage: rmtree1 dir .." ; exit 1 ; end

do i = 1 for ARG()
  call removeFileTree ARG(i)
end

exit 0

/* ----------- */

removeFileTree : procedure expose (globals)
  dirname = ARG(1)

  /* *NIX */
  dev = "/dev/null" ; cmd = "rm -fr" dirname
  address SYSTEM cmd with OUTPUT STREAM dev ERROR STREAM dev

  return

/* ----------------------------- */

/* rmtree2 - remove whole directory trees like rm -r */
if ARG() < 1 then do ; say "usage: rmtree2 dir .." ; exit 1 ; end

do i = 1 for ARG()
  call removeFileTree ARG(i)
end

exit 0

/* ----------- */

removeFileTree : procedure expose (globals)
  dirname = ARG(1)

  call processDirectories dirname, "removeDir", "removeFile"
  call removeDir dirname

  return

/* ----------- */

removeDir : ; call sysRMDir ARG(1) ; return
removeFile : ; call sysFileDelete ARG(1) ; return

/* ----------- */

processDirectories : procedure expose (globals)
  dirname = ARG(1) ; dirproc = ARG(2) ; fileproc = ARG(3)

  cmd = "call" dirproc "dir"

  call sysFileTree dirname||"/", 'dirtree.', 'do'

  if dirtree.0 > 0 then do
    do i = 1 to dirtree.0
      call processDirectories dirtree.i, dirproc, fileproc
      dir = dirtree.i ; interpret cmd
    end
  end

  call processFiles dirname, fileproc

  return

/* ----------- */

processFiles : procedure expose (globals)
  dirname = ARG(1) ; proc = ARG(2) ; cmd = "call" proc "file"

  call sysFileTree dirname||"/", 'files.', 'fo'
  do i = 1 to files.0
    file = files.i ; interpret cmd
  end

  return

/* @@PLEAC@@_9.9 */
NAMES = "f1 f2 f3 ..."

do while NAMES <> NULL
  parse var NAMES file NAMES ; newname = " ... "
  call sysMoveObject file, newname
  if RESULT \= 0 then
    say "Couldn't rename" file "to" newname ":" RESULT
end

/* ----------------------------- */

/*
   Command-line utilities may easily be used for this task, but it
   is important to consider how any output [i.e. stdout, stderr]
   will be handled, and whether return codes are significant and
   whether they should be checked.
*/

/* *NIX */
dev = "/dev/null" ; cmd = "mv" oldfile newfile
address SYSTEM cmd with OUTPUT STREAM dev ERROR STREAM dev
if RC \= 0 then ; say "Error ..."

/* OpenVMS */
dev = "NL:" ; cmd = "rename" oldfile newfile
address SYSTEM cmd with OUTPUT STREAM dev ERROR STREAM dev
if RC \= 1 then ; say "Error ..."

/*
   Win32 [Return codes unreliable, so best parse output for command
   status]
*/
dev = "NUL:" ; cmd = "ren" oldfile newfile
address SYSTEM cmd with OUTPUT STEM result. ERROR STREAM dev
parse var result.1 numberCopied .
if numberCopied \= 1 then ; say "Error ..."

/* ----------------------------- */

/*
   Note: Implementation is barely functionally equivalent to Perl's
   [owing to Perl's superior regex facilities], and is not as flexible,
   in particular it:

   * Expects a list of files on the command-line
   * Requires the 'expr' to be a regex because it will be passed to
     the 'subst' routine
   * Requires that 'expr' be passed as two arguments:
     - 'from' -> regex
     - 'to'   -> new name
*/

/* rename - Larry's filename fixer */
if ARG() < 1 then do ; say "usage: rename from to files" ; exit 1 ; end
from = ARG(1) ; to = ARG(2) ; files = ARG()

do i = 3 to files
  old = ARG(i) ; new = subst(old, from, to)
  if new \= old then ; call sysMoveObject old, new
end

exit 0

/* @@PLEAC@@_9.10 */
/* ------------------------------------------------------------------ */
/* This is no more than a parsing task, easily performed using PARSE  */
/* in combination with BIF's such as POS and LASTPOS. A simple example*/
/* follows:                                                           */
/*                                                                    */
/*   PATHSEP = "\" ; path = "c:\d1\d2\d3\file.ext"                    */
/*                                                                    */
/*   drive = "-1"                                                     */
/*   if POS(":", path) == 2 then do                                   */
/*     parse var path drive ":" name "." extension                    */
/*   end ; else do                                                    */
/*     parse var path name "." extension                              */
/*   end                                                              */
/*                                                                    */
/*   basename = SUBSTR(name, LASTPOS(PATHSEP, name) + 1)              */
/*   subdir = LEFT(name, LASTPOS(PATHSEP, name))                      */
/*                                                                    */
/*   say "[" || drive || "|" || name || "|" || extension || "|",      */
/*       || basename || "]"                                           */
/*   say subdir                                                       */
/*                                                                    */
/* For convenience this functionality has been included as the:       */
/*                                                                    */
/*   extractPathComponent                                             */
/*   extractPathComponents                                            */
/*                                                                    */
/* routines included in the Appendix. These routines currently only   */
/* recognise *NIX and Win32 paths, so cannot be said to be cross-     */
/* platform. It should not be too difficult to extend them to also    */
/* recognise paths / filespecs on other platforms such as:            */
/*                                                                    */
/*   VMS:   NODE"user pass"::device:[dir.subdir]filename.type;ver     */
/*   MacOS: drv:dir:file                                              */
/*   MVS:   dsnlvl1.dsnlvl2.dsnlvl3(member)                           */
/*          dsnlvl1.dsnlvl2.dsnlvl3                                   */
/*   CMS:   fn fmode ftype                                            */
/* ------------------------------------------------------------------ */

base = extractPathComponent(path, 'NAME')
dir = extractPathComponent(path, 'SUB')

parse value extractPathComponents(path, "NAME SUB EXT"),
      with base dir ext

/* ----------- */

path = "/usr/lib/libc.a"

file = extractPathComponent(path, 'NAME')
dir = extractPathComponent(path, 'SUB')

say "dir is" BL(dir) || ", file is" file

/* ----------- */

path = "/usr/lib/libc.a"

parse value extractPathComponents(path, "NAME SUB EXT"),
      with name dir ext

say "dir is" BL(dir) || ", name is" name || ", extension is ." || ext

/* ----------- */

path = "Hard%20Drive:System%20Folder:README.txt"

parse var path drive ":" folder ":" name "." ext

dir = drive || ":" || folder

say "dir is" dir || ", name is" name || ", extension is ." || ext

/* @@PLEAC@@_9.11 */
/* ------------------------------------------------------------------ */
/* Program: symirror                                                  */
/* ------------------------------------------------------------------ */

@@INCOMPLETE@@
@@INCOMPLETE@@

/* @@PLEAC@@_9.12 */
/* ------------------------------------------------------------------ */
/* Program: lst                                                       */
/* ------------------------------------------------------------------ */

@@INCOMPLETE@@
@@INCOMPLETE@@


/* @@PLEAC@@_10.0 */
/* ------------------------------------------------------------------ */
/* REXX supports two types of subroutine:                             */
/* * Internal Subroutine [A block of instructions commencing with a   */
/*   label, ending with a RETURN instruction]                         */
/*                                                                    */
/* * External Subroutine [Subroutine residing external to the caller  */
/*   in a separate script file; it's last statement will be an        */
/*   implied RETURN instruction unless an explicit RETURN or EXIT is  */
/*   used]                                                            */
/*                                                                    */
/* A REXX program, can itself, be considered an external subroutine.  */
/* As such, all variables are local to a subroutine which means that  */
/* there is no direct support for 'global' variables, though it is    */
/* possible to achieve a similar effect via:                          */
/*                                                                    */
/* * Adopting the convention whereby a program only uses internal     */
/*   subroutines; any variables declared at the 'program-level' can,  */
/*   in effect, be considered 'global' [though whether these are      */
/*   visible to internal subroutines is determined on an individual   */
/*   basis via the PROCEDURE and EXPOSE intructions]                  */
/*                                                                    */
/* * Using an external 'storage facility'. This is a common approach  */
/*   since common REXX usage sees it interact closely with the        */
/*   external environment                                             */
/*                                                                    */
/* Two types of subroutine calling conventions:                       */
/* * CALL instruction used to invoke subroutine designed as           */
/*   procedures i.e. those which RETURN no value. However, it may     */
/*   also be used to invoke a subroutine which does return a value    */
/*   - in this case it is placed in a variable called RESULT          */
/*                                                                    */
/* * Implict call for subroutines designed as functions; requires     */
/*   arguments enclosed in parentheses and the capture of the return  */
/*   value in a variable or as an argument in another function call.  */
/*   Argument list is, by convention, comma-separated, but may also   */
/*   be space-separated although this requires an adjustment in how   */
/*   arguments are extracted within the procedure                     */
/* ------------------------------------------------------------------ */

greeted = 0

call hello
greetings = howManyGreetings()
say "bye there!, there have been " greetings "greetings so far"

exit 0

/* ----------- */

hello :
  greeted = greeted + 1
  say "hi there!, this procedure has been called" greeted "times"
  return

/* ----------- */

howManyGreetings :
  return greeted

/* @@PLEAC@@_10.1 */
/* ------------------------------------------------------------------ */
/* REXX supports a flexible argument passing / extraction mechanism   */
/* in that arguments passed to a procedure are nothing more than a    */
/* list of strings.                                                   */
/*                                                                    */
/* The convention is to comma-separate arguments so that the          */
/* subroutine simply parses a comma-separated string to extract       */
/* arguments. It is, however, possible to circumvent convention and   */
/* adopt an alternate argument passing approach when required.        */
/*                                                                    */
/* Argument extraction is via the the PARSE ARG instruction, or via   */
/* the ARG() BIF, the latter used where manual parsing of the argument*/
/* list is to be performed.                                           */
/* ------------------------------------------------------------------ */

/* Load math functions from external library */
call rxFuncAdd 'mathLoadFuncs', 'rexxMath', 'mathLoadFuncs'
call mathLoadFuncs

/* In all cases, 'diag', contains the value 5 */ 
diag = hypotenuse(3, 4)
call hypotenuse 3, 4 ; diag = RESULT

diag = hypotenuse2(3, 4)
call hypotenuse2 3, 4 ; diag = RESULT

diag = hypotenuse3(3 4)
call hypotenuse3 3 4 ; diag = RESULT

/* Unload math functions */
call mathDropFuncs

exit 0

/* ----------- */

/* Extract comma-separated arguments via 'parse' instruction */
hypotenuse : procedure

  /* Extracting subroutine arguments - assumed comma-separated */
  parse arg side1, side2

  return SQRT((side1 ** 2) + (side2 ** 2))

/* ----------- */

/* Extract comma-separated arguments via 'ARG()' BIF */
hypotenuse2 : procedure

  /* Check number of [comma-separated] arguments passed */
  if ARG() \= 2 then return -1

  /* Extracting subroutine arguments - assumed comma-separated */
  side1 = ARG(1) ; side2 = ARG(2)

  return SQRT((side1 ** 2) + (side2 ** 2))

/* ----------- */

/* Extract space-separated arguments via 'ARG()' BIF */
hypotenuse3 : procedure

  /* Extracting subroutine arguments - assumed space-separated */
  parse value ARG(1) with side1 side2 .

  return SQRT((side1 ** 2) + (side2 ** 2))

/* @@PLEAC@@_10.2 */
/* ------------------------------------------------------------------ */
/* In REXX, all variables are local to a subroutine, thus a caller has*/
/* no direct access to the variables of a callee, something which     */
/* applies equally to both internal and external subroutines.         */
/*                                                                    */
/* An internal subroutine, since it is by definition, part of a REXX  */
/* program [therefore part of an external subroutine] is, by default, */
/* granted full access to the caller's variables. However, it is      */
/* possible to prevent such access via the PROCEDURE instruction, or  */
/* more selectively, via a combination of the PROCEDURE and EXPOSE    */
/* instructions.                                                      */
/*                                                                    */
/* Example:                                                           */
/*                                                                    */
/*     v1 = 5 ; v2 = 10                                               */
/*                                                                    */
/*     call f1                                                        */
/*     call f2                                                        */
/*     call f3                                                        */
/*                                                                    */
/*     exit 0                                                         */
/*                                                                    */
/*     f1 :                                                           */
/*       /* Access to caller's 'v1' and 'v2' */                       */
/*       v1 = 10 ; v2 = 15 ; return                                   */
/*                                                                    */
/*     f2 : procedure                                                 */
/*       /* No access to caller's variables - all local to 'f2' */    */
/*       v1 = 10 ; v2 = 15 ; return                                   */
/*                                                                    */
/*     f3 : procedure expose v1                                       */
/*       /* Access to caller's 'v1' only; 'v2' is local to 'f3' */    */
/*       v1 = 10 ; v2 = 15 ; return                                   */
/* ------------------------------------------------------------------ */

/*
   Unless 'variable' is declared in the caller, thus any reference
   to it is to the caller's, it is implicitly invisible outside of
   'somefunc'
*/
somefunc :
    variable = something  

/* ----------------------------- */

/*
   'variable' is implicitly invisible outside of 'somefunc' since
   even if the caller declared its own 'variable', it would not
   be visible here
*/
somefunc : procedure
    variable = something  

/* @@PLEAC@@_10.3 */
/* ------------------------------------------------------------------ */
/* REXX does not support persistent private variables, commonly known */
/* as 'static' variables in various languages. REXX *does* allow:     */
/* * Visibility of a 'local' variable to be restricted to certain     */
/*   subroutines, but the variable is not persistent - it's destroyed */
/*   once the current subroutine [caller] exits                       */
/* * A 'global' variable to be resticted to certain subroutines; if   */
/*   the variable is first used in the top-level caller then it may be*/
/*   considered persistent. However, it is also visible within the    */
/*   scope it was first used - so is not, strictly-speaking, private  */
/*                                                                    */
/* A common method for mimicing persistent private variables is to    */
/* globally share a 'stem' variable, and have each subroutine that    */
/* needs such items create a leaf [named after itself] on this stem.  */
/* This approach provides persistence whilst avoiding the inadvertent */
/* use of global names.                                               */
/* ------------------------------------------------------------------ */

/* -------------------------------
   REXX doesn't have unnamed scopes that allow declarations:

   {
      my $variable;
      sub mysub {
         # ... accessing $variable
      }
   }

   The following:

   BEGIN {
      my $counter = 42;
      sub next_counter { return ++$counter }
      sub prev_counter { return --$counter }
   }

   may be [roughly] implemented in two ways:
   ----------------------------- */

/* [1] Persistent, but not entirely private */
counter = 42

call next_counter
call next_counter
call prev_counter

exit 0

/* ----------- */

next_counter : procedure expose counter
  counter = counter + 1
  return counter

prev_counter : procedure expose counter
  counter = counter - 1
  return counter

/* ----------------------------- */

/* [2] Private, but not persistent */

BEGIN

exit 0

/* ----------- */

BEGIN : procedure
  counter = 42
  call next_counter
  call next_counter
  call prev_counter

  /* 'counter' destroyed once subroutine returns */
  return

/* ----------- */

next_counter : procedure expose counter
  counter = counter + 1
  return counter

prev_counter : procedure expose counter
  counter = counter - 1
  return counter

/* @@PLEAC@@_10.4 */
/* ------------------------------------------------------------------ */
/* REXX does not offer a standard means of obtaining the current      */
/* procedure name.                                                    */
/*                                                                    */
/* The PARSE instruction with argument SOURCE may be used to obtain:  */
/* * Operating System Name                                            */
/* * Invocation Mode of current script file                           */
/*                                                                    */
/* Various implementations extend the range of available information  */
/* with a third argument commonly being the name of the current script*/
/* file. If only external procedures are ever invoked then this value */
/* corresponds to the procedure name. It is otherwise not possible to */
/* obtain the name of an internal procedure except via some kludge,   */
/* which include:                                                     */ 
/*                                                                    */
/* * Pass the procedure name as a procedure argument                  */
/* * Force an error which then invokes the debugger; trap and parse   */
/*   this output [approach might even allow tracing the call stack    */
/*   but this *is not* a standard approach]                           */
/* ------------------------------------------------------------------ */

me = whoami("whoami")
him = whowasi("whowasi")

exit 0

/* ----------- */

whoami : procedure
  parse arg name
  return name

whowasi : procedure
  parse arg name
  return name

/* @@PLEAC@@_10.5 */
/* ------------------------------------------------------------------ */
/* REXX supports neither pass-by-reference, nor return-by-reference,  */ 
/* thus it is *not* possible [using in-built REXX facilities] to:     */
/*                                                                    */
/* * Pass a variable name / handle to a subroutine                    */
/* * Return a variable name / handle from a subroutine                */
/*                                                                    */
/* and use this item for updating a 'referred' object.                */
/*                                                                    */
/* Other languages possess similar restictions but can circumvent them*/
/* via other built-in facilities. For example, the C language supports*/
/* neither facility, but through its support of pointers mimics these */
/* facilities [i.e. a pointer acts like a handle to a memory block,   */
/* and by passing / returning pointer copies, several subroutines may */
/* all access (and optionally update) the contents of this item].     */
/*                                                                    */
/* In REXX, the following applies:                                    */
/*                                                                    */
/* * Shared access to variable(s) possible via the EXPOSE instruction */
/*   [i.e. controlled access to 'global' data]. This is the idiomatic */
/*   REXX approach though it may be considered by some to not wholly  */
/*   adhere to structured programming principles                      */
/*                                                                    */
/* * Use of a third party library that implements pointer-like or     */
/*   handle-like functionality. The third-party code used is 'RxHash' */ 
/*   library [details on availability in Appendix, and it is also     */
/*   extensively showcased in the PLEAC arrays section <<PLEAC_4.X>>] */
/*                                                                    */
/* The examples illustrate both approaches though emphasis is placed  */
/* on using the 'RxHash' library approach as it is closer in spirit to*/
/* the 'pass-by-reference' approach. Also, all 'RxHash' examples      */
/* assume the following prologue / epilogue:                          */
/*                                                                    */
/*   call rxFuncAdd 'arrLoadFuncs', 'rxHash', 'arrLoadFuncs'          */
/*   call arrLoadFuncs                                                */
/*   ...                                                              */
/*   call arrDropFuncs                                                */
/* ------------------------------------------------------------------ */

/* 'array_diff' Example 1: Data sharing via EXPOSE instruction */
array1.0 = 3 ; array1.1 = 'a' ; array1.2 = 'b' ; array1.3 = 'c'
array2.0 = 3 ; array2.1 = 'a' ; array2.2 = 'z' ; array2.3 = 'c'

/* Arguments need not be passed - done so to enhance code intent */
is_array_different = array_diff(array1, array2)

exit 0 

/* ----------- */

/* Subroutine has direct access to 'array1.' and 'array2.' variables */
array_diff : procedure expose array1. array2.
  /* Any passed arguments ignored - direct access to 'exposed' items */
  if array1.0 \= array2.0 then ; return TRUE

  /* Convention is that leaf '.0' of a stem variable contain is size */
  do i = 1 for array1.0
    if array1.i \= array2.i then ; return TRUE
  end
  return FALSE

/* ----------------------------- */

/* 'array_diff' Example 2(a): Data sharing via array handle-passing */
array1.0 = 3 ; array1.1 = 'a' ; array1.2 = 'b' ; array1.3 = 'c'
array2.0 = 3 ; array2.1 = 'a' ; array2.2 = 'z' ; array2.3 = 'c'

/* Dynamic 'arrays' created from stem variable contents */
array1Ptr = arrFromStem("array1.") ; array2Ptr = arrFromStem("array2.")

/* Dynamic array handles passed as arguments to subroutine */
is_array_different = array_diff(array1Ptr, array2Ptr)

/* Free dynamic array resources */
call arrDrop array1Ptr, array2Ptr

exit 0 

/* ----------- */

array_diff : procedure
  /* Extract arguments to obtain array handles */
  array1 = ARG(1) ; array2 = ARG(2)

  /* Compare array sizes - zeroeth element is array size */
  arrSize = arrGet(array1, 0)
  if arrSize \= arrGet(array2, 0) then ; return TRUE

  do i = 1 for arrSize
    if arrGet(array1, i) \= arrGet(array2, i) then ; return TRUE
  end
  return FALSE

/* ----------------------------- */

/* 'array_diff' Example 2(b): Data sharing via array handle-passing */

/* Dynamic 'arrays' created [Always place length in zeroeth element] */
array1Ptr = arrNew() ; call arrSet array1Ptr, 0, 0
array2Ptr = arrNew() ; call arrSet array2Ptr, 0, 0

/* Load arrays with data */
call arrSet array1Ptr, 1, 'a' ; call arrSet array2Ptr, 1, 'a'
call arrSet array1Ptr, 2, 'b' ; call arrSet array2Ptr, 2, 'z'
call arrSet array1Ptr, 3, 'c' ; call arrSet array2Ptr, 3, 'c'

/* Update array length */
call arrSet array1Ptr, 0, 3 ; call arrSet array2Ptr, 0, 3

/* Dynamic array handles passed as arguments to subroutine */
is_array_different = array_diff(array1Ptr, array2Ptr)

/* Free dynamic array resources */
call arrDrop array1Ptr, array2Ptr

exit 0 

/* Subroutine as for 2(a) */

/* ----------------------------- */

/* Create and load arrays */
a = arrNew() ; b = arrNew()
call arrSet a, 1, 1 ; call arrSet a, 2, 2 ; call arrSet a, 0, 2
call arrSet b, 1, 5 ; call arrSet b, 2, 8 ; call arrSet b, 0, 2

/* Compute results, capture return array */
c = add_vecpair(a, b)

/* Build output string */
arrSize = arrGet(c, 0) ; arrString = ""
do i = 1 for arrSize
  arrString = arrString arrGet(c, i)
end

/* Output: 6 10 */
say STRIP(arrString)

/* Release arrays */
call arrDrop a, b, c
 
/* ----------- */

add_vecpair : procedure
  /* Extract arguments to obtain array handles */
  array1 = ARG(1) ; array2 = ARG(2)

  /* Allocate dynamic array, set its size to zero */
  arrayRet = arrNew() ; call arrSet arrayRet, 0, 0

  /* Compare array sizes - zeroeth element is array size */
  arrSize = arrGet(array1, 0)
  if arrSize \= arrGet(array2, 0) then ; return arrayRet

  /* Compute vector sum */
  do i = 1 for arrSize
    call arrSet arrayRet, i, arrGet(array1, i) + arrGet(array2, i)
  end

  /* Update array size */
  call arrSet arrayRet, 0, arrSize

  return arrayRet

/* @@PLEAC@@_10.6 */
/* ------------------------------------------------------------------ */
/* Since REXX is a typeless language - the only 'type' is 'string', a */
/* sequence of characters - it isn't possible to determine the 'return*/
/* context' of a subroutine as is possible in Perl [i.e. Perl achieves*/
/* this feat by inspecting the stack looking for the type signature of*/
/* the variable 'capturing' the subroutine's return value (IIRC)].    */
/*                                                                    */
/* It is, however, possible to conditionally return values, be it the */
/* number of values, or the 'type' [loosely speaking] of values, based*/
/* on a control flag argument value. This is a rather conventional    */
/* approach capable of being used in many language environments. The  */
/* example shown will utilise this approach.                          */
/* ------------------------------------------------------------------ */

call mysub                                   /* Void Context */

scalar = mysub('S')                          /* Scalar Context */
if mysub('S') \= "" then ; nop

list = mysub('L')                            /* List Context */

exit 0

/* ----------- */

mysub : procedure
  parse upper arg retType

  if retType == 'S' then ; return 4          /* Scalar */
  if retType == 'L' then ; return "1 2 3 4"  /* List */

  return "" /* void */

/* @@PLEAC@@_10.7 */
/* ------------------------------------------------------------------ */
/* Argument passing to subroutines is entirely optional: all may be   */
/* legally called with zero or more arguments; whether they are used, */
/* or not, is a subroutine design issue. Looking at this another way, */
/* if arguments are passed to a subroutine then data is available for */
/* extraction [via the ARG BIF or PARSE ARG instruction] and use; if  */
/* no arguments were passed then any extraction results in empty [""] */
/* strings. No runtime argument-passing checks are otherwise made.    */
/*                                                                    */
/* REXX offers no formal support for 'named' parameters, or, for that */
/* matter, default parameters. However, it is easy to mimic both by   */
/* adopting a suitable convention. Examples of these appear below.    */
/* ------------------------------------------------------------------ */

call defaultParmExample             /* a = 'X', b = 'X', c = 'X' */
call defaultParmExample 1           /* a = 1,  b = 'X', c = 'X' */
call defaultParmExample 1, , 3      /* a = 1,  b = 'X', c = 3 */

exit 0

/* ----------- */

defaultParmExample : procedure
  defaultValue = 'X'

  /* Check whether argument(s) assigned */ 
  a = defaultValue ; if ARG(1) \= "" then ; a = ARG(1)
  b = defaultValue ; if ARG(2) \= "" then ; b = ARG(2)
  c = defaultValue ; if ARG(3) \= "" then ; c = ARG(3)

  /* Display each parameter and its assigned value */
  say "a =" a
  say "b =" b
  say "c =" c

  return

/* ----------------------------- */

call namedParmExample "a=1", "b=2", "c=cat"

exit 0

/* ----------- */

namedParmExample : procedure
  /* Extract argument count */
  argCount = ARG()

  do i = 1 for argCount
    /* Parse 'named' parameter and value */
    parse value ARG(i) with key '=' val

    /* Create and initialise 'named' parameter */
    call VALUE key, val
  end

  /* Display each 'named' parameter and its assigned value */
  say "a =" a
  say "b =" b
  say "c =" c

  return

/* ----------------------------- */

call thefunc "increment=20s", "start=+5m", "finish=+30m"
call thefunc "start=+5m", "finish=+30m"
call thefunc "finish=+30m"
call thefunc "start=+5m", "increment=15s"

exit 0

/* ----------- */

thefunc : procedure 
  /* Set default values */
  increment = '10s' ; finish = 0 ; start = 0

  /* Extract argument count */
  argCount = ARG()

  do i = 1 for argCount
    /* Parse 'named' parameter and value */
    parse value ARG(i) with key '=' val

    /* Create and initialise 'named' parameter */
    call VALUE key, val
  end

  /* Default values remain unless 'named' parameters were passed */
  if RIGHT(increment, 1) == "m" then ; nop

  return

/* @@PLEAC@@_10.8 */
/* ------------------------------------------------------------------ */
/* The PARSE instruction is generally used to tokenise a string. When */
/* used with the VALUE clause it is used to:                          */
/*                                                                    */
/* * Assign literals to a list of variables                           */
/* * Tokenise the return value of a function [shown below] or an      */
/*   expression                                                       */
/*                                                                    */
/* Since a string may be composed of several items, a function        */
/* returning a string allows it to mimic the returning of multiple    */
/* values. It also, almost invariably, requires the use of PARSE VALUE*/
/*                                                                    */
/* Since not all return values may be of significance on every call,  */
/* it is convention to use the '.' as the 'ignore' indicator - any    */
/* matching output is discarded.                                      */
/*                                                                    */
/* Examples use the following custom functions:                       */
/*                                                                    */
/* func : return "1 b cval"                                           */
/* stat : return "DEV INO X Y UID"                                    */
/* ------------------------------------------------------------------ */

parse value func() with a ignore c

/* Displays: 1 'b' 'cval' */
say a ignore c

/* ----------- */

parse value func() with a . c

/* Displays: 1 'cval' */
say a c

/* ----------- */

filename = "myfile.txt"
parse value stat(filename) with dev ino . . uid

/* Displays: 'DEV' 'INO' 'UID'  */
say dev ino uid

/* @@PLEAC@@_10.9 */
/* ------------------------------------------------------------------ */
/* As already described in <<PLEAC>>_10.8 a function may mimic the    */
/* returning of multiple variables by returning a string which is     */
/* tokenised into multiple values.                                    */
/*                                                                    */
/* As already described in <<PLEAC>>_10.5 REXX supports neither       */
/* pass-by-reference, nor return- by-reference, but can use a 'handle-*/
/* based' approach [with the help of a third-party library] to 'share'*/
/* arrays among several subroutines.                                  */
/*                                                                    */
/* Sadly these two techniques cannot be combined since handles are,   */
/* themselves, strings, and cannot be arbitrarily combined and taken  */
/* apart. It is, however, possible to use the stack to return a fixed,*/
/* or arbitrary number of such items from a subroutine. Its caller is,*/
/* of course, responsible for any stack cleanup.                      */
/*                                                                    */
/* Stack use is quite simple:                                         */
/*                                                                    */
/* * Place items on stack via:                                        */
/*                                                                    */
/*     queue ITEM   [FIFO order retrieval]                            */
/*     push ITEM    [LIFO order retrieval]                            */
/*                                                                    */
/* * Extract items from stack [somewhat like reading a file] via:     */
/*                                                                    */
/*     do while QUEUED() > 0                                          */
/*       parse pull ITEM                                              */
/*       /* Do something with ITEM ... */                             */
/*     end                                                            */
/*                                                                    */
/*   Another technique involves placing [and later retrieving] the    */
/*   number of items in the stack; a counted loop can then be used for*/
/*   item retrieval.                                                  */
/*                                                                    */
/* Only a single example is shown - a modification of the 'somefunc'  */
/* Perl example - that uses a counted loop for stack retrieval. The   */
/* variables used map as follows:                                     */ 
/*                                                                    */
/*   array_ref.0  -->  Number of stack items                          */
/*   array_ref.1  -->  $array_ref                                     */
/*   array_ref.2  -->  $hash_ref                                      */
/* ------------------------------------------------------------------ */

/* Return value is the number of items to be extracted from stack */
array_ref.0 = somefunc()

/* Use counted loop to retrieve 'returned' array handles */
do i = 1 for array_ref.0
  /* Extract item [array handle] from stack */
  parse pull array_ref.i

  /* Display array handle 'length' to prove items are intact */
  say "Length of array_ref."||i "=" arrGet(array_ref.i, 0)

  /* Free array handle */
  call arrDrop array_ref.i
end

exit 0

/* ----------- */

somefunc : procedure
  /* Create two dynamic arrays, set their sizes to arbitrary values */
  arrayRet1 = arrNew() ; call arrSet arrayRet1, 0, 3
  arrayRet2 = arrNew() ; call arrSet arrayRet2, 0, 4

  /* Return array handles on the stack for FIFO retrieval */
  queue arrayRet1 ; queue arrayRet2 

  /* Return number of array handles returned */
  return 2

/* @@PLEAC@@_10.10 */
/* ------------------------------------------------------------------ */
/* Like so many programming languages, the empty string - "" - may be */
/* used to indicate that a subroutine 'failed'. This is, of course, a */
/* convention only, purely an arbitrary choice.                       */ 
/*                                                                    */
/* In order to improve the readability of examples, the variable NULL */
/* has been assigned the empty string value, so code such as:         */
/*                                                                    */
/*   return ""                                                        */
/*                                                                    */
/* and:                                                               */
/*                                                                    */
/*   return NULL                                                      */
/*                                                                    */
/* is equivalent.                                                     */
/* ------------------------------------------------------------------ */

return ""

/* ----------- */

empty_retval : return ""

/* ----------- */

a = yourfunc()

/* 'nop' means 'No operation' - same as Python's 'pass' */
if a == "" then ; nop 

/* ----------------------------- */

a = sfunc()
if a == "" then do
  ERRTXT = "sfunc failed"
  signal assertionError
end

/* ----------- */

assertionError : 
  say ERRTXT
  exit 1

/* @@PLEAC@@_10.11 */
/* ------------------------------------------------------------------ */
/* REXX does not require / support the prototyping of subroutines. A  */
/* subroutine is simply assumed to exist as one of a:                 */ 
/*                                                                    */
/* * Label [Internal Subroutine]                                      */ 
/* * File [External Subroutine]                                       */
/*                                                                    */
/* when a subroutine invocation is encountered. If the interpreter    */
/* fails to locate the subroutine then a SYNTAX error is thrown.      */ 
/* ------------------------------------------------------------------ */

/* *** Translation skipped *** */

/* @@PLEAC@@_10.12 */
/* ------------------------------------------------------------------ */
/* REXX does sport several types of built-in exception. However, REXX */
/* at least as defined in the ANSI standard, doesn't support user-def-*/
/* ined exceptions, nor does it allow the user to raise any of them.  */
/* It is, therefore, not possible to implement exact equivalents to   */
/* the Perl examples [some REXX interpreters do, however, overcome    */
/* these limitations].                                                */
/*                                                                    */
/* Instead, a simple example illustrating exception handling [called  */
/* CONDITION handling in REXX] will be provided.                      */
/* ------------------------------------------------------------------ */

/* Install exception handlers */

/*
   These will not return control, thus they should each
   perform some sort of appropriate error handling e.g. message
   display / logging, application cleanup, etc, and then exit
   the application
*/
signal on HALT name HALT_Handler
signal on SYNTAX name SYNTAX_Handler
signal on NOVALUE name NOVALUE_Handler

/*
   These return control, thus it is possible to recover from
   a problem
*/
call on ERROR name ERROR_Handler
call on FAILURE name FAILURE_Handler
call on NOTREADY name NOTREADY_Handler

/*
   Do something that causes a signal to be raised. Here we
   assign to an undefined variable. A NOVALUE condition is
   raised, and NOVALUE_Handler is invoked
*/ 

a = a + 1

exit 0

/* ----------- */

/* Exception handlers */

/* Thse exit from application */
SYNTAX_Handler :
  say "SYNTAX Condition"
  say "Line:" SIGL
  say CONDITION('D')
  exit 1
  return

HALT_Handler :
  say "HALT Condition"
  say "Line:" SIGL
  say CONDITION('D')
  exit 1
  return

NOVALUE_Handler :
  say "NOVALUE Condition"
  say "Line:" SIGL
  say CONDITION('D')
  exit 1
  return

/* These return to caller */
ERROR_Handler :
  say "ERROR Condition"
  say "Line:" SIGL
  say CONDITION('D')
  return

FAILURE_Handler :
  say "FAILURE Condition"
  say "Line:" SIGL
  say CONDITION('D')
  return

NOTREADY_Handler :
  say "NOTREADY Condition"
  say "Line:" SIGL
  say CONDITION('D')
  return

/* @@PLEAC@@_10.13 */
/* ------------------------------------------------------------------ */
/* REXX does not support true 'global' variables, therefore it does   */
/* not implement the equivalent of Perl's LOCAL whereby a local name  */
/* can be made to override a global name for current block duration.  */
/* The closest facility offered in REXX are the PROCEDURE and EXPOSE  */
/* instructions, but these apply only to the subroutine to which they */
/* are applied, not on a block-basis like Perl's LOCAL.               */
/*                                                                    */
/* See PLEAC 10.2 for examples of PROCEDURE and EXPOSE                */
/* ------------------------------------------------------------------ */

/* *** Translation skipped *** */

/* @@PLEAC@@_10.14 */
/* ------------------------------------------------------------------ */
/* REXX subroutines are identified via labels. Unlike variables which */
/* may be undefined via the DROP instruction, labels cannot be        */
/* undefined. Any attempt to redefine a subroutine will be ignored -  */
/* ony the first definition in the source file will be recognised.    */
/*                                                                    */
/* Example:                                                           */
/*                                                                    */
/*     call f                                                         */
/*     exit 0                                                         */
/*                                                                    */
/*     /* Multiple subroutines - only the first one is recognised */  */
/*     f : say "First 'f'"; return                                    */
/*     f : say "Second 'f'"; return                                   */
/*     f : say "Third 'f'"; return                                    */
/*                                                                    */
/* Nor is it possible to assign the name of a subroutine to a         */
/* variable, and execute it *indirectly*. This is because REXX does   */
/* not support the notion of object 'address' or 'reference'. In      */
/* short, the whole concept of aliasing is entirely foreign to REXX.  */
/*                                                                    */
/* Aliasing-type behaviour is possible in REXX via:                   */
/*                                                                    */
/* * VALUE BIF                                                        */
/* * INTERPRET instruction                                            */
/*                                                                    */
/* but the approach taken is to build an expression, then dynamically */
/* evaluate it [the INTERPRET instruction is similar to the 'eval'    */
/* facility in Perl and Python].                                      */
/* ------------------------------------------------------------------ */

/* A call to label, 'expand' */
call expand

/* Variable, 'grow', assigned literal, 'expand'
grow = 'expand'

/* A call to label [not variable], 'grow' */
call grow

/* Both equivalent to: 'call expand' */
interpret 'call' grow
interpret 'call' VALUE('grow')

exit 0

/* ----------- */

grow : say 'grow' ; return
expand : say 'expand' ; return

/* ----------------------------- */

two.Table = "X" ; two.small = "Y"

one.var = 'two.Table'
one.big = 'two.small'

interpret 'say' VALUE('one.var')
interpret 'say' VALUE('one.big')

/* ----------------------------- */

fred = 'barney'       
interpret VALUE('fred') '=' 15

say fred      /* fred = 'barney' */
say barney    /* barney = 15 */

/* ----------------------------- */

s = 'red("careful here")'
interpret 'say' VALUE('s')

s = 'green("careful there")'
interpret 'say' VALUE('s')

s = 'blue("careful everywhere")'
interpret 'say' VALUE('s')

/* ----------- */

color_font :
  parse arg color, text
  return "<FONT COLOR='" || color || "'>" || text || "</FONT>"

red :
  parse arg text ; return color_font("red", text)
green :
  parse arg text ; return color_font("green", text)
blue :
  parse arg text ; return color_font("blue", text)

/* @@PLEAC@@_10.15 */
/* ------------------------------------------------------------------ */
/* REXX does not sport an AUTOLOAD facility. However, should a        */
/* non-existent subroutine be invoked the interpreter will signal a   */
/* SYNTAX error, typically Syntax Error Number 43 - "Routine not      */
/* found". It is possible to install a subroutine which checks for    */
/* this condition, and then takes appropriate recovery steps, perhaps */
/* copying an external subroutine from another location, or maybe     */
/* generating one, and then reattempting the subroutine invocation.   */
/*                                                                    */
/* Note, however, this approach is quite limited:                     */
/* * The undefined procedure cannot be identified                     */
/* * SYNTAX class errors are not directly recoverable because control */
/*   is not returned to the line following the error [because the     */
/*   SIGNAL instruction must be used which possesses a GOTO-like      */
/*   behaviour]                                                       */
/*                                                                    */
/* Example:                                                           */
/*                                                                    */
/*     /* Commands are system-specific - examples are Win32 */        */
/*     DELCMD = "del/q notExistFunc.rexx"                             */
/*     GENCMD = "@echo say 'I am notExistFunc' > notExistFunc.rexx"   */
/*                                                                    */
/*     main :                                                         */
/*       /* Install SYNTAX error handler */                           */
/*       signal on SYNTAX name notExistFuncTrap                       */
/*                                                                    */
/*       /* Call an undefined subroutine */                           */
/*       call notExistFunc                                            */
/*                                                                    */
/*       /* If here, subroutine *was* executed */                     */
/*       say "'notExistFunc' called ok"                               */
/*                                                                    */
/*       /* Delete subroutine before exiting */                       */
/*       address system DELCMD                                        */
/*                                                                    */
/*       exit 0                                                       */
/*                                                                    */
/*     /* SYNTAX error handler */                                     */
/*     notExistFuncTrap :                                             */
/*       say "'notExistFunc' not found, so generating it ..."         */
/*                                                                    */
/*       /* Generate missing subroutine */                            */
/*       address system GENCMD                                        */
/*                                                                    */
/*       /* Retry operation by branching back to known label */       */
/*       signal main                                                  */
/* ------------------------------------------------------------------ */

/* *** Translation skipped *** */

/* @@PLEAC@@_10.16 */
/* ------------------------------------------------------------------ */
/* REXX does not support the nesting of subroutines; these must all be*/
/* top-level, and it is not possible to restrict their visibility. If */
/* nesting *is* attempted control returns from the point in the outer */
/* subroutine where the first inner subroutine is defined; this can be*/
/* a difficult problem to diagnose.                                   */
/* ------------------------------------------------------------------ */

/* WRONG ! */
outer : procedure
  parse arg x
  x = x + 35

  inner : return x * 19 /* 'inner' block executed; 'outer' returns */

  return x + inner()    /* this line is never executed !!! */

/* ----------- */

/* OK, don't nest subroutines; alter access with PROCEDURE */
outer : procedure
  parse arg x
  x = x + 35
  return x + inner()    /* this line now executes */

inner : return x * 19   /* 'inner' has direct access to 'x' */


/* @@PLEAC@@_12.0 */
/* ------------------------------------------------------------------ */
/* A REXX program is just a sequence of instructions residing in a    */
/* file. It may pass control to labelled blocks of code residing in   */
/* the same file [internal subroutines], as well as to other REXX     */
/* programs which, in this context, are known as external subroutines.*/
/* Things worth noting:                                               */
/*                                                                    */
/* * REXX possesses no formal notion of the module / package concept; */
/*   each program is a standalone, totally independant entity with no */
/*   program being able to - directly - access the contents of another*/
/*   program                                                          */
/*                                                                    */
/* * The name of a REXX program plays no part in naming or otherwise  */
/*   identifying any of that program's contents. Thus, there is also  */
/*   no notion of namespace, nor is it possible to create an alias for*/
/*   an existing entity. Each subroutine used in a program must be    */
/*   named so as to be uniquely identifiable                          */
/*                                                                    */
/* * REXX possesses no pre-processing facility, thus conditional code */
/*   inclusion [e.g. debugging code, code from other source files]    */
/*   is not possible                                                  */
/*                                                                    */
/* The lack of a module/package system may be of concern to some, just*/
/* as a lack of pre-processing facility may be to others. However, it */
/* should be remembered that REXX was designed to be an easy-to-use,  */
/* general purpose, end-user tool, one which would facilitate the     */
/* creation of simple scripts such as those for one-off tasks or for  */
/* tying together several applications. Key to ensuring its achieving */
/* this goal is to keep the language simple, and facilities offered   */
/* quite minimal. Put simply, REXX was not intended for large-scale,  */
/* team-based development, so does not offer facilities which cater   */
/* to this.                                                           */
/*                                                                    */
/* Of course it is possible to implement such functionality, though of*/
/* course it would not be as 'clean', and sophisticated as would the  */
/* equivalent native facility:                                        */
/*                                                                    */
/* * A compilation step could be introduced using an an external pre- */
/*   processor [e.g. third-party package like 'm4' or a script written*/
/*   in REXX or other tool like 'awk']. This would allow conditional  */
/*   code inclusion in the same way it is achieved in C using #define */
/*   and #include.                                                    */
/*                                                                    */
/* * Use the filesystem [e.g. directories / folders] to act as module */
/*   or packages in much the same way it is done in Perl and Java     */
/*                                                                    */
/* * Package a REXX file as a module [i.e. collection of subroutines],*/
/*   and adopt the convention of invoking a particular subroutine when*/
/*   the 'module' [invoked as an external subroutine] is accessed     */
/*                                                                    */
/* These techniques will be described in the relevant sections. The   */
/* third approach - REXX file as module - will be used in all the     */
/* sections where Perl package / module use is made. However, given   */
/* the very significant differences between REXX and Perl, these, and */
/* other examples will differ from the original cookbook code.        */
/*                                                                    */
/* Finally, related to the idea of modules, is REXX support for ext-  */
/* ernal libraries [i.e. collections of machine code routines]. These */
/* cannot be considered true modules because they are not part of the */
/* core language. However, their use is key to extending REXX funct-  */
/* ionality, so it is important to understand how they are used. As   */
/* the examples will show they are managed in a manner quite like     */
/* Perl modules.                                                      */
/* ------------------------------------------------------------------ */

/*
   The first Perl example ['Alpha / Omega'] illustrates how a 'package'
   can be created 'on the fly'. Inapplicable to REXX.
*/

/* ----------------------------- */

/*
   The second Perl example illustrates both the compile-time and run-
   tie loading of packages / modules. Neither applies to REXX; the
   closest equivalent is to check for the availability of a REXX file
*/

/* Run-time availability check i.e. ensure 'FileHandle.rexx' exists */
available = require("FileHandle.rexx")
available = require("FileHandle")

if available then ; say "'FileHandle' package is available"
else ; say "'FileHandle' package *NOT* available"

/* ----------- */

available = require("Cards/Poker.rexx")

if available then ; say "'Cards/Poker' package is available"
else ; say "'Cards/Poker' package *NOT* available"

/* ----------------------------- */

/*
   Rough outline of how a REXX file might be stuctured to play the
   role of a 'module'. Example is roughly functionally equivalent to
   the Perl example
*/

/* Contents of file, 'Poker.rexx' located in 'Cards' directory */

/*

  /* Module Name */
  _modname = "Poker"
  ...

  /* Method List [i.e. exports] */
  _methods = "shuffle getCardDeck setCardDeck"
  ...

  /* Method Implementations */
  shuffle : procedure ...
  getCardDeck : procedure ...
  setCardDeck : procedure ...
  ...

*/

/* @@PLEAC@@_12.1 */
/* ------------------------------------------------------------------ */
/* Since REXX does not support modules this issue is moot. However an */
/* outline of how to implement a 'REXX file as module' is shown; in   */
/* the current section an outline of how to structure, then use, one  */
/* is provided, whilst a complete implementation [and example of use] */
/* appears in the second last section of this chapter.                */
/*                                                                    */
/* Implementing a 'module' system in REXX is actually quite simple. It*/
/* makes use of some key REXX features:                               */
/*                                                                    */
/* * A source file is self-contained: all contents are private to that*/
/*   file, thus making it an ideal vehicle for acting as a 'module'   */
/*                                                                    */
/* * A source file is callable as an external subroutine, and is able */
/*   to accept arguments, and return result(s) to the caller          */
/*                                                                    */
/* * The INTERPRET instruction allows for the evaluation of arbitrary */
/*   strings as code. Therefore, it is possible to pass the name of a */
/*   subroutine, and any arguments it might require, to a subroutine  */
/*   and have *that* subroutine execute                               */
/*                                                                    */
/* as well as requiring an adherence to certain conventions:          */
/*                                                                    */
/* * Module data access must be via 'accessor' subroutines and updates*/
/*   via 'mutator' subroutines                                        */
/*                                                                    */
/* * Module subroutine calls are via argument passing to module file  */
/*   calls                                                            */
/*                                                                    */
/* * Module data is stored via some 'persistence' mechanism [since a  */
/*   module is really a REXX subroutine, data is destroyed on exit;   */
/*   any data needing to be retained needs to be externally stored]   */
/*                                                                    */
/* * Metadata such as the module name, version, and perhaps list of   */
/*   subroutines [and optionally associated descriptions] be kept as  */
/*   module data [and suitable accessors provided]                    */
/*                                                                    */
/* All these ideas appear in the module example in the second last    */
/* section of this chapter.                                           */
/* ------------------------------------------------------------------ */

/* *** Translation skipped *** */

/* @@PLEAC@@_12.2 */
/* ------------------------------------------------------------------ */
/* REXX lack of module support makes it unnecessary for it to offer   */
/* facilities / keywords like Perl's 'require' or 'use'. If a native  */
/* REXX subroutine is to be invoked [particularly an internal routine]*/
/* it is simply assumed to exist. Calling a non-existent routine will */
/* raise a SYNTAX condition which can, of course, be trapped, but this*/
/* approach is rarely worth the trouble as it merely complicates the  */
/* application design [an extensive example is in <<PLEAC>>_10.15].   */
/*                                                                    */
/* Invoking an external subroutine assumes that it resides in a known */
/* location, thus a check for its presence can be made prior to the   */
/* call, and appropriate recovery steps taken [i.e. look for it else- */
/* where, generate the required code, etc ...]. This is, in effect,   */
/* an implementation of 'require'-like functionality. The example in  */
/* the previous section well-illustrates the use of the custom routine*/
/* 'require', for this task, as well as how module information may be */
/* obtained [though a simple example also appears below].             */
/*                                                                    */
/* A run-time facility akin to module use is the loading / registering*/
/* of external library functions [i.e. machine code routines residing */
/* in shared library files]. REXX sports a complete API for handling  */
/* such entities, including the ability to test whether any such have */
/* been correctly loaded.                                             */
/*                                                                    */
/* Library loading is actually a two-step process:                    */
/*                                                                    */
/* * Loading the library file [i.e. shared library / DLL]             */
/* * Loading the desired function [a step repeated for each function] */
/*                                                                    */
/* A convention has been adopted for such libraries in which both a   */
/* a loader [of all functions] and an unloader function are provided  */
/* to facilitate library function handling. The example below shows   */
/* their use.                                                         */
/*                                                                    */
/* Another means of trapping 'module' errors is to introduce a kind of*/
/* 'compilation step', something easily achieved via the use of a pre-*/
/* processor. For example, one could adopt the convention that a line */
/* such as:                                                           */
/*                                                                    */
/*    #include "myModule.rexx"                                        */
/*                                                                    */
/* would see a search for the relevant file made, and its contents    */
/* inlined starting at that location. Failure to locate and include   */
/* the 'module' would see a 'complation' error signalled, and remedial*/
/* steps taken. Needless to say, the pre-processor could be something */
/* like a small REXX or awk script, or a sophisticated application    */
/* such as 'm4'.                                                      */
/* ------------------------------------------------------------------ */

if \require("modulename") then ; say "Couldn't load 'modulename'"

/* ----------- */

modulelist = "Giant/Eanie Giant/Meanie Mouse/Mynie Moe"

do while modulelist <> NULL
  parse var modulelist mod modulelist
  if \require(mod) then ; say "Couldn't load" mod
end

/* ----------------------------- */

/* *** Regina-specific Examples *** */

/* Dynamically adding / removing external library functions */

/* Load general-purpose functions from external library */

/* [1] Load / register the 'library loader' function */
if \rxFuncAdd('sysLoadFuncs', 'rexxUtil', 'sysLoadFuncs') then
  say "Error loading ..."

/* [2] Call the 'library loader' function to load *all* functions */
call sysLoadFuncs

/* Use some of these general-purpose function(s) */
call sysCls

/* Invoke 'unloader' function to remove all functions from memory */
call sysDropFuncs

/* @@PLEAC@@_12.3 */
/* ------------------------------------------------------------------ */
/* Since REXX does not support modules the issue of delaying their use*/
/* until runtime is moot. Additionally, using the 'external subroutine*/
/* as module' approach [as has been extensively done] sees all module */
/* contents unavailable until it is actually needed. Thus, the issue  */
/* delaying module loading does not arise.                            */
/* ------------------------------------------------------------------ */

/* *** Translation skipped *** */

/* @@PLEAC@@_12.4 */
/* ------------------------------------------------------------------ */
/* Assuming the conceit of having a REXX file / external subroutine   */
/* mimic a 'module', it should be noted that all variables declared   */
/* within that file are local to that file. Therefore, the issue of   */
/* making variables private to a module is not one applicable in REXX.*/
/*                                                                    */
/* Whilst on this matter, it should be pointed out that it is not     */
/* possible to make those variables externally accessable, nor is it  */
/* possible to make those variables persistent. Both tasks *can* be   */
/* accomplished, albeit indirectly, through the use of an external    */
/* storage system together with a set of 'accessor' methods.          */
/*                                                                    */
/* The example below - based on the first Perl example in this section*/
/* - illustrates the above except that variables are non-persistent   */
/* [persistent variables are illustarted elsewhere].                  */
/* ------------------------------------------------------------------ */

/* Module Name */
_modname = "Alpha"
...

/* Method List [i.e. exports] */
_methods = "getAA setAA getX setX"
...

/* Data [private, non-persistent, set to initial values] */
aa = NULL ; x = NULL
...

/* Method Implementations */
getAA : procedure expose aa ; return aa
setAA : procedure expose aa ; aa = ARG(1) ; return aa

getX : procedure expose x ; return x
setX : procedure expose x ; x = ARG(1) ; return x
...

/* ----------- */

/* As above [with appropriate name changes] for package, 'Beta' */

/* ----------- */

if requires("Alpha") then do
  call Alpha "setAA", 10
  call Alpha "setX", "azure"
end

if requires("Beta") then do
  call Beta "setBB", 20
  call Beta "setX", "blue"
end

/* In current package */
say Alpha("getAA") Beta("getBB") Alpha("getX") Beta("getX")

/* @@PLEAC@@_12.5 */
/* ------------------------------------------------------------------ */
/* The only information obtainable about a caller is information      */
/* actually passed to the callee such as, for example, the caller's   */
/* name. The Perl examples are, therefore, not translatable.          */
/* ------------------------------------------------------------------ */

/* *** Translation skipped *** */

/* @@PLEAC@@_12.6 */
/* ------------------------------------------------------------------ */
/* Since REXX does not support modules the issue of automating their  */
/* cleanup is moot. However, it does help highlight the issue of      */
/* application cleanup, something of equal importance especially where*/
/* there are external resources which must be properly released prior */
/* to application exit.                                               */
/*                                                                    */
/* REXX does not implement the equivalent of Perl's END block, so it  */
/* not possible to specify code blocks that must *always* execute e.g.*/
/* like a C++ destructor. It does, however, allow the trapping of     */
/* certain CONDITIONS [roughly the same as Perl signals], and the     */
/* specifying of handlers for those conditions.                       */
/*                                                                    */
/* A condition may be raised by the interpreter, or by the program    */
/* [via an explicit 'signal CONDITION' instruction]. An easy way to   */
/* ensure a block of code is executed both at the end of normal exe-  */
/* cution, and when a condition is raised is to place such code at the*/
/* end of the application. The Perl-equivalent example below uses this*/
/* approach.                                                          */
/* ------------------------------------------------------------------ */

/* Outline of a 'cleanup' subroutine triggered by HALT and SYNTAX */

/* Set 'cleanup' routine to trigger specified conditions */
signal on SYNTAX name cleanup
signal on HALT name cleanup

/* ... application main body ... */

exit 0

/* ----------- */

/* Application 'cleanup' routine */
cleanup :
  /* ... cleanup tasks ... */
  exit 0

/* ----------------------------- */

/* As per Perl example */

LOG = "mylogfile.txt"

/* Control jumps to 'cleanup' in the event of a raised condition */
signal on SYNTAX name cleanup
signal on HALT name cleanup

call logmsg LOG, "startup"

/* ... application main body ... */

/* Control falls through to this block under normal execution */
cleanup :
  call logmsg LOG, "shutdown"
  exit 0

/* ----------- */

logmsg : procedure expose (globals)
  logfile = ARG(1) ; message = ARG(2)
  call LINEOUT logfile, message
  return

/* @@PLEAC@@_12.7 */
/* ------------------------------------------------------------------ */
/* Keeping your own module directory                                  */
/* ------------------------------------------------------------------ */

@@INCOMPLETE@@
@@INCOMPLETE@@

/* @@PLEAC@@_12.8 */
/* ------------------------------------------------------------------ */
/* REXX is an interpreted language, therefore, a REXX application is  */
/* normally distributed as a set of source files [it is assumed that  */
/* intended client / user possesses a suitable interpreter; refer to  */
/* later section on interpreter installation / distribution].         */
/*                                                                    */
/* Considerations:                                                    */
/*                                                                    */
/* * Any general purpose distribution tool may be used; packaging up  */
/*   applications as .zip or .tgz files is common and easy to do, as  */
/*   is the use of utilities such as InstallShield to largely automate*/
/*   application installation                                         */
/*                                                                    */
/* * REXX compilers are available. Aside from the performance benefits*/
/*   obtainable via such tools, it avoids the need for source code    */
/*   distribution                                                     */
/*                                                                    */
/* * A particularly useful tool is Rexx/Wrapper, available from:      */
/*                                                                    */
/*     http://rexxwrapper.sourceforge.net/doc/index.html              */
/*                                                                    */
/*   This utility bundles up source code [optionally encrypted] into  */
/*   executable form, simplifying and helping secure the application  */
/*   distribution process.                                            */
/* ------------------------------------------------------------------ */

/* Sample Rexx/Wrapper Session [not all required options shown] */

/*
    /* Command-line use [may also be used interactively]
    rexx rexxwrap.cmd -options ...

    /* Create 'Planets' module distribution package [incomplete] */
    rexx rexxwrap.cmd -program Planets -rexxfiles /home/Planets.rexx

    /* Create 'Planets' module distribution package [incomplete] */
    rexx rexxwrap.cmd -program Orbits -rexxfiles /home/Orbits.rexx
*/

/* @@PLEAC@@_12.9 */
/* ------------------------------------------------------------------ */
/* REXX does not implement a facility like Perl's Self Loader. Hence  */
/* this concept is inapplicable in REXX.                              */
/* ------------------------------------------------------------------ */

/* *** Translation skipped *** */

/* @@PLEAC@@_12.10 */
/* ------------------------------------------------------------------ */
/* REXX does not implement a facility like Perl's Auto Loader. Hence  */
/* this concept is inapplicable in REXX.                              */
/* ------------------------------------------------------------------ */

/* *** Translation skipped *** */

/* @@PLEAC@@_12.11 */
/* ------------------------------------------------------------------ */
/* Implementing a subroutine having the same name as a built-in [BIF] */
/* sees the replacement subroutine invoked whenever that name is used */
/* in a call. Unfortunately, it also renders the BIF inaccessable, and*/
/* it is not even possible to call the BIF from within the replacement*/
/* subroutine. Hence, this is a practice best avoided in REXX.        */
/*                                                                    */
/* The lack of native module support renders this concept otherwise   */
/* inapplicable in REXX.                                              */
/* ------------------------------------------------------------------ */

/* Call the built-in 'TIME' function; displays the actual HH:MM:SS */
say TIME('N')

/* ----------------------------- */

/* Call 'TIME' function override; displays the string "[[HH:MM:SS]]" */
say TIME('N')

/* ----------- */

TIME : procedure expose (globals)
  return "[[HH:MM:SS]]"

/* @@PLEAC@@_12.12 */
/* ------------------------------------------------------------------ */
/* REXX BIF's will generally raise SYNTAX conditions to signal errors */
/* such as, for example, the passing of invalid arguments. It is quite*/
/* possible to both:                                                  */
/*                                                                    */
/* * Override the default SYNTAX condition handler so as to customise */
/*   the handling of BIF errors                                       */
/*                                                                    */
/* * Mimic this error trapping / handling strategy in custom code     */
/*                                                                    */
/* An example of each is shown; only the second is based on the Perl  */
/* cookbook code.                                                     */
/* ------------------------------------------------------------------ */

/* Customised BIF Error Handling */

/* Install handler [default name is 'SYNTAX'] for SYNTAX condition */
signal on SYNTAX

/* ... */

/* Force SYNTAX condition: invoke 'TIME' BIF with erroneous argument */
say TIME('Z')

/* ... */

/* SYNTAX condition handler */
SYNTAX :
  /* Display error information, and exit interprter */
  say makeErrorMsg(40, SIGL)
  exit 1

/* ----------- */

/* Displays error information in same format as default handler */
makeErrorMsg :
  n = ARG(1) ; lineno = ARG(2) ; parse source . . name
  return "Error" n "running" '"' || name || '", line',
         lineno || ":" ERRORTEXT(n)

/* ----------------------------- */

/* Custom Subroutine Error Handling */

call even_only 2                      /* Executes ok */

call even_only 3                      /* Error trapped and reported */

/* ----------- */

even_only : procedure expose (globals)
  n = ARG(1) ; signal on SYNTAX name eo_error

  if (n // 2) > 0 then ; signal SYNTAX
  /* ... */
  return TRUE

eo_error :
  say "Error in 'even_only' subroutine: is not even"
  return FALSE

/* @@PLEAC@@_12.13 */
/* ------------------------------------------------------------------ */
/* Since REXX does not support modules this issue is moot. Examples,  */
/* are therefore not translatable.                                    */
/* ------------------------------------------------------------------ */

/* *** Translation skipped *** */

/* @@PLEAC@@_12.14 */
/* ------------------------------------------------------------------ */
/* There is, AFAIK, no publically-available REXX translation tool that*/
/* is similar in functionality to Perl's 'h2ph' utility.              */
*/
/* ------------------------------------------------------------------ */

@@INCOMPLETE@@
@@INCOMPLETE@@

/* @@PLEAC@@_12.15 */
/* ------------------------------------------------------------------ */
/* There is, AFAIK, no publically-available REXX translation tool that*/
/* is similar in functionality to Perl's 'h2xs' utility.              */
*/
/* ------------------------------------------------------------------ */

/* *** Translation skipped *** */

/* @@PLEAC@@_12.16 */
/* ------------------------------------------------------------------ */
/* There is, AFAIK, no publically-available documentation generation  */
/* tool for REXX [though, doubtless, a significant number do exist,   */
/* though as proprietary products].                                   */
/*                                                                    */
/* However, there are a number of general purpose documentation tools */
/* available. A particularly useful one is ROBODoc, available from:   */
/*                                                                    */
/*     http://www.xs4all.nl/~rfsber/Robo/robodoc.html                 */
/*                                                                    */
/* This product is language-neutral, and works something like the very*/
/* widely used javadoc tool [Java Documentation] in that it scans the */
/* source code it is fed looking for specially-formatted comments from*/
/* which it extracts information and assembles it into one of several */
/* formats including HTML and PDF.                                    */
/*                                                                    */
/* ROBODoc is fully configurable, but does recognise several comment  */
/* types by default, including that for the C language. Since REXX    */
/* utilises the same comment type it is possible to use it 'out of the*/
/* box' by using the C language commentary conventions. What could be */
/* easier :) ?                                                        */
/* ------------------------------------------------------------------ */

/* *** Translation skipped *** */

/* @@PLEAC@@_12.17 */
/* ------------------------------------------------------------------ */
/* Since REXX does not support modules the issue of installing such is*/
/* moot. However, it is worth discussing the issue of REXX interpreter*/
/* distribution / installation [REXX application distribution and     */
/* installation was discussed in an earliuer section].                */
/*                                                                    */
/* Quite obviously this is both an interpreter-specific and platform- */
/* specific issue. In the case of Regina, a popular implementation    */
/* which emphasises cross-platform workability, installation options  */
/* for several platforms are available. In fact, the one interpreter  */
/* package may be used to generate interpreter executables for several*/
/* platforms. See: http://regina-rexx.sf.net                          */
/* ------------------------------------------------------------------ */

/*
   Sample Regina REXX Installation Session for *NIX / Linux
   ---
   % ./configure
   % make install
*/

/* ----------------------------- */

/*
   Sample Regina REXX Installation Session for OpenVMS
   ---
   % @BUILD
*/

/* ----------------------------- */

/*
   Sample Regina REXX Installation Session for Win32
   ---
   1. Unzip archive file

   2. Copy the files:
      * regina.exe
      * regina.dll
      into a directory specified in your PATH environment variable

   3. [Optional] configuration steps outlined in documentation
*/

/* @@PLEAC@@_12.18 */
/* ------------------------------------------------------------------ */
/* Example: Module Template                                           */
/*                                                                    */
/* The following example consists of:                                 */
/*                                                                    */
/* * A complete 'module' implementation                               */
/* * A complete module usage example                                  */
/*                                                                    */
/* The only assumption made is that the module reside in a REXX source*/
/* file having the same name as the module [in this case, 'modtime']. */
/* More details on module structure is in the earlier section on      */
/* module interfaces.                                                 */
/* ------------------------------------------------------------------ */

/* *** Module name and version *** */
_modname = "modtime" ; _modversion = 1.0

/* ----------------------------- */

/* *** Module Constants *** */
FALSE = 0 ; TRUE = 1 ; NULL = "" ; NEWLINE = "0A"X ; SPACE = ' '
globals = "sys. env. args. $. FALSE TRUE NULL NEWLINE SPACE"

/* ----------------------------- */

/* *** Module Non-persistent Storage *** */

/* ... */

/* ----------------------------- */

/* *** Module routine table *** */
/* [1] Housekeeping routines list */
_code = "init cleanup getModuleName getModuleVersion getMethodList"

/* [2] User methods list */
_method = "getTime setTime"

/* ----------------------------- */

/* *** Module Entry Point / Method Dispatcher *** */
parse value ARG(1) with _proc "," . ; _args = ARG() ; _arglist = NULL

/* Extract arguments and construct callable routine */
if _args > 1 then do
  do i = 2 to _args ; _arglist = _arglist ARG(i) ; end
  _cmd = "_result =" _proc || "(" || STRIP(_arglist) || ")"
end ; else do
  _cmd = "_result =" _proc || "()"
end

/* Ensure constructed routine is actually a module routine */
if \hasCode(_proc) & \hasMethod(_proc) then ; return NULL

/* Invoke routine and return its result to caller */
interpret _cmd ; return _result

/* ----------------------------- */

/* *** Module Code *** */

/* [1] Housekeeping Routines */

init :
  /* Module setup routine [i.e. module 'constructor'] */
  call setTime DATE()
  return NULL

/* ----------- */

cleanup :
  /* Module cleanup rotuine [i.e. module 'destructor'] */
  return NULL

/* ----------- */

/* Module Information Accessors */
getModuleName : ; return _modname
getModuleVersion : ; return _modversion
getMethodList : ; return _method

/* ----------- */

/* Module Validation Routines */
hasCode : ; return POS(ARG(1), _code) > 0
hasMethod : ; return POS(ARG(1), _method) > 0
hasGlobal : ; return LENGTH(VALUE(ARG(1),, 'SYSTEM')) > 0

/* ----------- */

/* External Persistent Storage */
updateGlobal : ; call VALUE ARG(1), ARG(2), 'SYSTEM' ; return NULL
extractGlobal : ; return VALUE(ARG(1),, 'SYSTEM')

/* ----------------------------- */

/* [2] User Methods */

getTime : procedure expose (globals)
  /* Extract value of "TIME" from external storage */
  return extractGlobal("TIME")

/* ----------- */

setTime : procedure expose (globals)
  /* Set "TIME" in external storage to specified value */
  call updateGlobal "TIME", ARG(1)
  return ARG(1)

/* ----------------------------- */ /* ----------------------------- */

/* Module Usage Example */

/* Application Options */
options 'NO_STRICT_ANSI'
trace 'OFF'
signal on NOVALUE

/* Global Constants */
FALSE = 0 ; TRUE = 1 ; NULL = "" ; NEWLINE = "0A"X ; SPACE = ' '

/* Global Roots and 'expose' list */
globals = "sys. env. args. $. FALSE TRUE NULL NEWLINE SPACE"

/* ----------- */

/* Check module availability */
available = require("modtime")

if available then do

  /* Initialise module */
  call modtime "init"

  /* Extract and print module information */
  name = modtime("getModuleName")
  version = modtime("getModuleVersion")
  methods = modtime("getMethodList")

  say "Module 'modtime' is available"
  say "Details:"
  say "   Name:" name
  say "   Version:" version
  say "   Methods:" methods

  /* Invoke user-available module routine(s) */
  say modtime("getTime")

  /* Cleanup module */
  call modtime "cleanup"

end ; else do
  say "Module 'modtime' *NOT* available"
end

/* ----------------------------- */

/* Current implementation is Win32 / *NIX specific */
require : procedure expose (globals)

  /* Extract PATH components */
  parse value ARG(1) with name "." extension ; version = ARG(2)
  if extension == NULL then ; extension = "rexx"
  path = name || "." || extension

  /* Check file / module existence, and its version [if required] */
  if LENGTH(STREAM(path,'C',"QUERY EXISTS")) > 0 then do
    if version == NULL then ; return TRUE
    _cmd = "_result =" name || '("getModuleVersion")'
    interpret _cmd ; return _result == version
  end

  return FALSE

/* @@PLEAC@@_17.0 */
/* ------------------------------------------------------------------ */
/* REXX socket support is via third-party library. The one utilised   */
/* in this chapter is the RxSock Library [see Appendix for details],  */
/* an implementation which, because it is so widely available, and on */
/* so many different platforms, can be taken as being the standard    */
/* [albeit a 'defacto' one] approach to socket handling. Its use      */
/* [on most platforms] assumes the following prologue code is used:   */
/*                                                                    */
/*     call rxFuncAdd 'sockLoadFuncs', 'rxSock', 'SockLoadFuncs'      */
/*     call sockLoadFuncs                                             */
/*                                                                    */
/* and the following epilogue code [usually at program's end]:        */
/*                                                                    */
/*     call sockDropFuncs                                             */
/*                                                                    */
/* Please note that the name of the library may be case-sensitive in  */
/* some environments e.g. in *NIX / Linux environments the name may   */
/* need to be changed to, 'rxsock' to match part of the file name,    */
/* 'librxsock.so'. Other RxSock library issues are discussed below.   */
/*                                                                    */
/* Like similar libraries in other languages, the RxSock library is   */
/* basically a set of routines that map to the TCP/IP Socket API [i.e */
/* they are 'wrappers' around  C functions] that is available on prob-*/
/* ably every Internet-connected computer. Using this library will be */
/* quite straightforward for those already familiar with this API. For*/
/* others it should be no more difficult than learning file handling  */
/* and related techniques. The following tutorials may be of use:     */
/*                                                                    */
/* * http://www.frostbytes.com/~jimf/papers/sockets/winsock.html      */
/* * http://wi.wu-wien.ac.at/rgf/rexx/tmp/socktut.pdf                 */
/*                                                                    */
/* The RxSock library is notable for being easy to use partly because */
/* there are fewer data conversion issues with which to contend. For  */
/* example an issue needing handling in even high-level languages like*/
/* Perl and Python is the conversion of a host address in a 'packed'  */
/* format [i.e. 32 bit binary value] to / from human-readable string. */
/* In REXX both hostnames and IP addresses are represented in string  */
/* form [from the programmer's perspective], thus eliminating one area*/
/* of potential difficulty.                                           */
/*                                                                    */
/* RxSock library issues:                                             */
/*                                                                    */
/* * Behavioural and syntax variations among implementations:         */
/*   - Not all socket options universally applicable                  */
/*   - Not all socket routines work on all platforms                  */
/*   - Protocal inconsistancies such as UDP working well in one imple-*/
/*     mentation but not on another                                   */
/*   - Routine name/parameter differences                             */
/*                                                                    */
/* * Minimal and/or inconsistent raw socket support. Whilst "SOCK_RAW"*/
/*   type sockets may be specified in 'sockSocket' calls, not all     */
/*   implementations create such sockets; some simply return an error */
/*   value in place of a socket. Also, there is no support for either */
/*   IPPROTO_RAW or IPPROTO_ICMP protocols, thus, effectively, there  */
/*   really is *no* raw socket support                                */
/*                                                                    */
/* * Error handling differs between implementations. Some update the  */
/*   'errNo' variable, whilst others implement a 'sockErrNo' variable;*/
/*   safest to rely on checking for negative return value as an error */
/*   indicator                                                        */
/*                                                                    */
/* It is probably safe to say that the RxSock library is suitable for */
/* conventional socket programming [i.e. projects involving either TCP*/
/* or UDP transports]. If anything more specialist is required either */
/* the library needs to be modified [possible: source code supplied], */
/* or access to suitable wrapper functions or another external library*/
/* be made available.                                                 */
/*                                                                    */
/* Some comments on forking ...                                       */
/*                                                                    */
/* Finally, it is possible to use the General Call Interface [GCI] to */
/* directly access socket-related functions [e.g. 'gethostname']; it  */
/* is safest to avoid this practice because it can see the avoidance  */
/* of sometimes vital initialisation steps. For example, in the Win32 */
/* environment, the 'WSAStartup' function needs to be called prior to */
/* using any socket-related functions, and, for proper cleanup, the   */
/* corresponding 'WSACleanup' function should be called. Such steps   */
/* are performed as part of 'rxSock' external library housekeeping,   */
/* so best use those routines for such functionality.                 */
/* ------------------------------------------------------------------ */

/* Load general-purpose functions from external library */
call rxFuncAdd 'sysLoadFuncs', 'rexxUtil', 'sysLoadFuncs'
call sysLoadFuncs

/* Load rxSock functions from external library */
call rxFuncAdd 'sockLoadFuncs', 'rxSock', 'SockLoadFuncs'
call sockLoadFuncs

/* ----------------------------- */

/*
   RxSock library does not use 'packed' IP addresses, so the custom
   subroutines, 'inet_aton', and 'inet_ntoa', whilst having been
   implemented [to illustrate byte <=> string conversion in REXX],
   are not actually required for socket-based communication
*/

/* Convert human readable form to 32 bit value */
packed_ip = inet_aton("208.201.239.36")

drop host. ; call sockGetHostByName "www.oreilly.com", 'host.!'
packed_ip = inet_aton(host.!ADDR)

/* ----------------------------- */

/* Convert 32 bit value to ip address */
ip_address = inet_ntoa(packed_ip)

/* ----------------------------- */

/* Create socket object */
family = 'AF_INET' ; type = 'SOCK_STREAM'
protocol = 'IPPROTO_TCP' /* or '0' for default */

socketobj = sockSocket(family, type, protocol)

/* ----------- */

/* Extract local-side details of this socket */ 
drop host. ; call sockGetSockName socketobj, 'host.!'

/*
   host.!ADDR => 0.0.0.0 unless connected
   host.!PORT => 0 unless connected
*/

/* ----------------------------- */

/*
   Helper functions
*/

die : procedure expose (globals)
  call LINEOUT , ARG(1) ; exit ARG(2) ; return NULL

/* ----------- */

isValidIP : procedure expose (globals)
  ip = ARG(1) ; lastType = DATATYPE(SUBSTR(ip, LASTPOS(".", ip) + 1))
  if ip == NULL | COUNTSTR(".", ip) \= 3 | lastType \= 'NUM' then
    return FALSE
  do while ip <> NULL
    parse var ip octet "." ip
    if DATATYPE(octet) \= 'NUM' then ; return FALSE
    if octet < 0 | octet > 255 then ; return FALSE
  end
  return TRUE

/* ----------- */

inet_aton : procedure expose (globals)
  ip = ARG(1) ; packed = NULL
  do while ip <> NULL
    parse var ip octet "." ip
    packed = packed || D2X(octet, 2)
  end
  return X2C(packed)

/* ----------- */

inet_ntoa : procedure expose (globals)
  packed = C2X(ARG(1)) ; parse var packed octet +2 packed
  ip = X2D(octet)
  do while packed <> NULL
    parse var packed octet +2 packed
    ip = ip || "." || X2D(octet)
  end
  return ip

/* @@PLEAC@@_17.1 */
/*
   Establishing a simple, TCP-based client connection to a host
*/

/* Create socket */
peer = sockSocket('AF_INET', 'SOCK_STREAM', '0')

if peer < 0 then
  call die "Couldn't create socket :" socksock_errno(), 1

/* Set up for peer connection */
drop peer.
peer.!FAMILY = 'AF_INET'
peer.!ADDR = "192.168.1.1"  /* Target ipaddr */
peer.!PORT = 13             /* Target port */

/* Make the connection */
if sockConnect(peer, 'peer.!') < 0 then
  call die "Couldn't connect socket to" peer.!ADDR || ":" ||,
           peer.!PORT, ":" socksock_errno(), 1

/* Do something with the socket ... */
if sockSend(peer, "Why don't you call anymore?" || NEWLINE) < 0 then
  call die "Error sending data on socket :" socksock_errno(), 1

MAX_BYTES = 256

if sockRecv(peer, 'answer', MAX_BYTES) < 0 then
  call die "Error receiving data from socket :" socksock_errno(), 1

/* Terminate when done - close socket, releasing all its resources */
if sockClose(peer) < 0 then
  call die "Error closing socket :" socksock_errno(), 1

/* ----------------------------- */

/*
   Additional Perl examples either redundant because with RxSock:
   * It is not possible to specify host information as part of the socket
     creation call
   * There is only one set of procedures for setting up and handling
     connections
*/

/* ----------------------------- */

/* Set up for listening on specified port */
drop assoc.
assoc.!FAMILY = 'AF_INET'
assoc.!ADDR = 'INADDR_ANY'   /* Use first defined [local] ipaddr */
assoc.!PORT = 23             /* Port on which to listen */

/* Bind to socket */
if sockBind(socket, 'assoc.!') < 0 then
  call die "Error binding to socket :" socksock_errno(), 1

/* ----------- */

drop assoc. ; call sockGetHostByName "www.oreilly.com", 'assoc.!'

/* Bind to socket */
if sockBind(socket, 'assoc.!') < 0 then
  call die "Error binding to socket :" socksock_errno(), 1

/* @@PLEAC@@_17.2 */
/*
   Implementing a simple, TCP-based server

   The Perl examples are consolidated into the following, single code,
   example because, while Perl offers multiple socket libraries and
   options, REXX uses 'rxSock', a set of wrapper functions, whose use
   varies little except for argument-passing differences 
*/

/* Service will be available on port 1996 */
port = 1996

/* Create socket */
server = sockSocket('AF_INET', 'SOCK_STREAM', '0')

if server < 0 then
  call die "Couldn't create server socket :" socksock_errno(), 1

/* Allow socket reuse */
if sockSetSockOpt(server, 'SOL_SOCKET', 'SO_REUSEADDR', 1) < 0 then
  call die "Couldn't set options on server socket :" socksock_errno(), 1

/* Set up for server connection */
drop server.
server.!FAMILY = 'AF_INET'
server.!ADDR = 'INADDR_ANY'   /* Use first defined [local] ipaddr */
server.!PORT = port           /* Port on which to listen */

/* Need to bind socket to port, then commence listening on that port */
if sockBind(server, 'server.') < 0 then
  call die "Couldn't bind server socket to port :" socksock_errno(), 1

/* Queue up 1 connection only */
if sockListen(server, 1) < 0 then
  call die "Couldn't commence listening on server socket :",
           socksock_errno(), 1

MAX_BYTES = 256

/* Poll for client connections */
do forever
  /* Block until a connection comes in */
  client = sockAccept(server)

  if client < 0 then
    call die "Error accepting client connection :" sockErrNo, 1
  
  /* Service client ... */

  if sockRecv(client, 'buffer', MAX_BYTES) < 0 then
    call die "Error receiving data from client socket :",
             socksock_errno(), 1

  say "|" buffer "|"

  if sockSend(client, "..." || NEWLINE) < 0 then
    call die "Error responding on client socket :" socksock_errno(), 1

  if sockShutDown(client) < 0 then
    call die "Error shutting down client socket :" socksock_errno(), 1

  if sockClose(client) < 0 then
    call die "Error closing client socket :" socksock_errno(), 1

  leave

  /* ... */
end

/*
   Terminate when done - shutdown, close the socket, and release all
   its resources
*/
if sockShutDown(server) < 0 then
  call die "Error shutting down server socket :" socksock_errno(), 1

if sockClose(server) < 0 then
  call die "Error closing server socket :" socksock_errno(), 1

/* @@PLEAC@@_17.3 */
/* ------------------------------------------------------------------ */
/* Once a socket is created, and a TCP-based connection established,  */
/* it may be used for *bidirectional* communication, that is, for both*/
/* writing to, and reading data from, a host.                         */
/*                                                                    */
/* Perl allows the use of 'file descriptor semantics' for this task in*/
/* addition to specialised subroutines / methods. This is not the case*/
/* in REXX where the following 'rxSock' library routines must be used:*/
/*                                                                    */
/* * Reading: sockRecv, sockRecvFrom [datagrams]                      */
/* * Writing: sockSend, sockSendTo [datagrams]                        */
/*                                                                    */
/* ------------------------------------------------------------------ */

/*
   No REXX equivalent to Perl 'file descriptor semantics':

       print $SERVER "What is your name?\n";
       chomp ($response = <SERVER>);
*/

/* ----------------------------- */

/*
   Examples assume same names / values from previous two examples:

   peer    --> client-side socket connected to server; peer reads and
               writes to server using this socket 
   server  --> server-side socket; waits for clients to call, then
               creates a client socket for each new client
   client  --> server-side socket representing connection from peer;
               server reads and writes to peer using this socket
*/

/* ----------------------------- */

data_to_send = "..."

call sockSend peer, data_to_send || NEWLINE

if sockErrNo \= 0 then
  call die "Error sending data on socket :" sockErrNo, 1

/* ----------- */

data_read_buffer = NULL ; MAX_BYTES = 256

call sockRecv peer, 'data_read_buffer', MAX_BYTES

if sockErrNo \= 0 then
  call die "Error receiving data from socket :" sockErrNo, 1

/* ----------------------------- */

/*
  'select' [using 'sockSelect'] example
  ---
  's1', 's2', and 's3' are previously-created sockets. The compound
  variable contains the sockets for which 'readable' status is to be
  determined
*/
reads.0 = 3 ; reads.1 = s1 ; reads.2 = s2 ; reads.3 = s3

/* 5 second timeout [omit argument to have 'sockSelect' block] */
timeout = 5

/* Issue call; success sees 'count' > 0, 'reads.' updated */
count = sockSelect('reads.',,, timeout)

/* Check 'select' status */
select
  when count == -1 then
    /* Same as checking for 'sockErrNo' \= 0 */
    call die "Error in 'sockSelect' call :" sockErrNo, 1

  when count == 0 then
    /* ... handle timeout ...*/
    say "'sockSelect' timeout"

  when count > 0 then
    /*
       Successful status update:

       reads.0       --> Number of 'readable' sockets 
       reads.1 ... N --> Set of sockets that are 'readable' [input
                         values have been overwritten]
    */

    /* ... handle success ...*/

end

/* ----------------------------- */

/* Enable TCP_NODELAY on socket */
call sockSetSockOpt server, 'SOL_SOCKET', 'TCP_NODELAY', 1

if sockErrNo \= 0 then
  call die "Couldn't disable Nagle's algorithm :" sockErrNo, 1

/* ----------- */

/* Disable TCP_NODELAY on socket */
call sockSetSockOpt server, 'SOL_SOCKET', 'TCP_NODELAY', 2

if sockErrNo \= 0 then
  call die "Couldn't enable Nagle's algorithm :" sockErrNo, 1

/* @@PLEAC@@_17.6 */
/* ------------------------------------------------------------------ */
/* 'rxSock' library supports Internet Domain sockets [AF_INET]; there */
/* is no support for UNIX Domain Sockets [AF_UNIX].                   */
/*                                                                    */
/* It is, however, possible [*NIX-only] to use GCI to access C library*/
/* functions like 'socketpair' to handle such entities, an approach   */
/* that will not be shown here. See section 6.9 of UNIX Network Progr-*/
/* amming by W. R. Stevens for an in-depth treatment of this topic.   */
/* ------------------------------------------------------------------ */

/* *** Translation skipped *** */

/* @@PLEAC@@_17.7 */
/* ------------------------------------------------------------------ */
/* This task relies on the 'getpeername' functionality commonly found */
/* in socket libraries. Rather than tap into this directly via GCI, an*/
/* intermediary in the form of an external library wrapper function is*/
/* more commonly used.                                                */
/* ------------------------------------------------------------------ */

/*
   RxSock library does not use 'packed' IP addresses, so the custom
   subroutines, 'inet_aton', and 'inet_ntoa', whilst having been
   implemented [to illustrate byte <=> string conversion in REXX],
   are not actually required for socket-based communication
*/

/* Default socket: blocking, 'AF_INET', 'SOCK_STREAM' */
socket = sockSocket()

if sockErrNo \= 0 then
  call die "Couldn't create socket :" sockErrNo, 1

/* Retrieve peer [i.e. remote side] information from socket */
drop host. ; call sockGetPeerName socket, 'host.!'
if sockErrNo \= 0 then
  call die "Couldn't identify other end :" sockErrNo, 1

iaddr = host.!ADDR ; port = host.!PORT

/* ----------------------------- */

drop host. ; call sockGetHostByAddr iaddr, 'host.!'
if sockErrNo \= 0 then
  call die "Couldn't identify other end :" sockErrNo, 1

claimed_hostname = host.!NAME

drop host. ; call sockGetHostByName claimed_hostname, 'host.!'
if sockErrNo \= 0 then
  call die "Couldn't look up" claimed_hostname ":" sockErrNo, 1

if iaddr \== host.!ADDR then
  call die "Mismatch between" claimed_hostname "and" iaddr ":",
           sockErrNo, 1

/* @@PLEAC@@_17.8 */
/* ------------------------------------------------------------------ */
/* This task relies on the 'gethostname' functionality commonly found */
/* in socket libraries. Rather than tap into this directly via GCI, an*/
/* intermediary, be it a system command or wrapper functions, is more */
/* commonly used.                                                     */
/* ------------------------------------------------------------------ */

/* Execute system command, 'hostname', placing output in 'hostname.1' */
address SYSTEM "hostname" with OUTPUT STEM hostname.

/* ----------------------------- */

/* Call the non-ANSI [*NIX-only] 'UNAME' BIF extracting all data */
parse value UNAME() with kernel, hostname, release, version, hardware

/* Alternatively, call 'UNAME' for a specified field */
hostname = UNAME('N')

/* ----------------------------- */

hostname = "sparx.net"

drop host. ; call sockGetHostByName hostname, 'host.!'
if sockErrNo \= 0 then
  call die "Couldn't resolve" hostname ":" sockErrNo, 1

iaddr = host.!ADDR

drop host. ; call sockGetHostByAddr iaddr, 'host.!'
if sockErrNo \= 0 then
  call die "Couldn't re-resolve" hostname ":" sockErrNo, 1

/* 'host.!NAME' should now be the same value as: 'hostname' */

/* @@PLEAC@@_17.9 */
/* ------------------------------------------------------------------ */
/* Two caveats when using 'sockShutdown':                             */
/*                                                                    */
/* * Non-blocking call, so a delay may be needed after calling it     */
/* * A call to 'sockClose' is still required at some point to release */
/*   socket resources [it does not replace this function]             */
/* ------------------------------------------------------------------ */

call sockShutdown socket, 0             /* Stopped reading data */
call sockShutdown socket, 1             /* Stopped writing data */
call sockShutdown socket, 2             /* Stopped using this socket */

/* ----------------------------- */

call sockShutdown socket, 0

if sockErrNo \= 0 then
  call die "Couldn't effect socket shutdown :" sockErrNo, 1
else
  say "I have stopped reading"

/* ----------------------------- */

/* Send some data */
buffer = "my request"||NEWLINE
call sockSend SERVER, buffer

/* Send eof; no more writing */
call sockShutdown SERVER, 1                  

/* Can, however, still read */ 
call sockRecv SERVER, 'answer', MAX_BYTES