View source for REXX Tips & Tricks:Sample source code

This section contains some sample source code. (see also Using the samples)

==Using ANSI sequences==
This section contains some routines for the display and for redefining of keys using ANSI sequences. (see also ANSI ESC Sequences) 

===Check if ANSI is active - 1 -===
<pre>
/* sample routine to check if ANSI is activated                       */
/*                                                                    */
/* see also Check if ANSI is active - 2 -                             */
/*                                                                    */

  i = CheckAnsi()
  if i = 1 then
    say "ANSI is activated"
  else
    if i = 0 then
      say "ANSI is not activated."
    else
      say "Error detecting ANSI."

exit 0

/* ------------------------------------------------------------------ */
/* function: Check if ANSI is activated                               */
/*                                                                    */
/* call:     CheckAnsi                                                */
/*                                                                    */
/* where:    -                                                        */
/*                                                                    */
/* returns:  1 - ANSI support detected                                */
/*           0 - no ANSI support available                            */
/*          -1 - error detecting ansi                                 */
/*                                                                    */
/* note:     Tested with the German and the US version of OS/2 3.0    */
/*                                                                    */
/*                                                                    */
CheckAnsi: PROCEDURE
  thisRC = -1

  trace off
                        /* install a local error handler              */
  SIGNAL ON ERROR Name InitAnsiEnd

  "@ANSI 2>NUL | rxqueue 2>NUL"

  thisRC = 0

  do while queued() <> 0
    queueLine = lineIN( "QUEUE:" )
    if pos( " on.", queueLine ) <> 0 | ,                       /* USA */
       pos( " (ON).", queueLine ) <> 0 then                    /* GER */
      thisRC = 1
  end /* do while queued() <> 0 */

InitAnsiEnd:
RETURN thisRC
</pre>

===Check if ANSI is active - 2 -===
<pre>
/* sample routine to check if ANSI is activated (using REXXUTIL)      */
/* based on a idea and code of Erik Schneller                         */
/* (see EMail Addresses)                                              */
/*                                                                    */
/* see also Check if ANSI is active - 1 -                             */
/*                                                                    */
  i = CheckAnsi()
  if i = 1 then
    say "ANSI is activated"
  else
    if i = 0 then
      say "ANSI is not activated."
    else
      say "Error detecting ANSI."

exit 0

/* ------------------------------------------------------------------ */
/* function: Check if ANSI is activated                               */
/*                                                                    */
/* call:     CheckAnsi                                                */
/*                                                                    */
/* where:    -                                                        */
/*                                                                    */
/* returns:  1 - ANSI support detected                                */
/*           0 - no ANSI support available                            */
/*          -1 - error detecting ansi                                 */
/*                                                                    */
/* note:     Tested with the German and the US version of OS/2 3.0    */
/*           based on a idea and code of Erik Schneller               */
/*           (see EMail Addresses)                                    */
/*                                                                    */
/*                                                                    */
CheckAnsi: PROCEDURE
  thisRC = -1

                        /* install a local error handler              */
  SIGNAL ON ERROR Name InitAnsiEnd

                    /* register the function SysCurPos from REXXUTIL  */
  call rxFuncAdd "SysCurPos", "REXXUTIL", "SysCurPos"

                    /* get and save the current cursor position       */
  curPos = SysCurPos()

                    /* write a CR/LF and the ANSI code for CursorUp   */
  call charOut , D2C(13) || "1B"x || "[1A"

                    /* now get the current cursor position            */
  NewPos=SysCurPos()

                    /* compare the new position to the old position   */
  if LEFT( NewPos,2 ) == LEFT( curPos,2 ) THEN
  do
                    /* ANSI support is OFF                            */
     thisRC = 0

                /* goto the begin of the line and delete the garbage  */
     call CharOut, D2C(13) || copies( " ",4 ) || D2C(13)
  end /* if left( ... */
  else
  do
                    /* ANSI support is ON                             */

                    /* restore the old cursor position                */
    call CharOut , "1B"x || "[B"
    thisRC = 1
  end /* else */

InitAnsiEnd:
RETURN thisRC
</pre>

===Get the current cursor position===
<pre>
/* sample routine to get the current cursor position with plain REXX  */
/* and ANSI commands                                                  */
/* Original code is from the ANSICD package from Jamie Hoglund        */

  parse value GetCursorPos() with col row
  say "At program start the cursor was at " || ,
      "Column " || col || ", Row " || row || "."
exit 0

/* ------------------------------------------------------------------ */
/* function: Get the current cursor position                          */
/*                                                                    */
/* call:     GetCursorPos                                             */
/*                                                                    */
/* returns:  col row                                                  */
/*                                                                    */
/* note:     This function works only for display sizes up to 200 for */
/*           columns or rows. The upper left corner is 1,1.           */
/*           The REXXUTIL function SysCurPos uses zero based values   */
/*           (the upper left corner is 0,0).                          */
/*           Caution:                                            v2.90*/
/*           The REXX Queue must be empty for this code to work!      */
/*           If the REXX Queue is not empty, you can use code         */
/*           like                                                     */
/*             - create a new                                         */
/*             - make the new queue the default queue                 */
/*             - call GetCursorPos                                    */
/*             - make the old queue the default queue again           */
/*             - delete the new queue                                 */
/*                                                                    */
GetCursorPos: PROCEDURE
  usedChars = ":;<=>?@ABCD"

  Rc = Charout(,D2C(27) || "[6n")
  Pull Q

                                                             /* v2.30 */
  parse var q 3 y1 +1 y2 +1 3 row +2 6 x1 +1 x2 +1 6 col +2 .

  if pos( y1, usedChars ) <> 0 then
    row = 10 || y2

  if pos( x1, usedChars ) <> 0 then
    col = 10 || x2

return col row
</pre>

===Get the current screen size===
<pre>
/* sample routine to get the current screensize for textmode windows  */
/* without using REXXUTIL functions.                                  */

  parse value GetDisplaySize() with columns rows
  say "The current OS/2 window size is " || ,
      rows || " rows and " || columns || " columns."
exit 0

/* ------------------------------------------------------------------ */
/* function: Get the current display size                             */
/*                                                                    */
/* call:     GetDisplaySize                                           */
/*                                                                    */
/* returns:  columns rows                                             */
/*                                                                    */
/* note:     This function works only for display sizes up to 200 for */
/*           columns or rows. The upper left corner is 1,1.           */
/*           The REXXUTIL function SysCurPos uses zero based values   */
/*           (the upper left corner is 0,0).                          */
/*                                                                    */
GetDisplaySize: PROCEDURE expose thisPos

  usedChars = ":;<=>?@ABCD"

                    /* save current cursor position                   */
  rc = CharOut(, D2C(27) || '[' || "6n")
  pull curPos

                    /* try to set the cursor to the position 200,200  */
  rc = CharOut(, D2C(27) || '[' || "200;200H" )

                    /* get cursor position                            */
  rc = CharOut(, D2C(27) || '[' || "6n")
  pull tPos

                    /* restore current cursor position                */
  rc = CharOut(, substr( curPos,1, length( curPos)-1) || "H" )

                                                             /* v2.30 */
  parse var tPos 3 y1 +1 y2 +1 3 rows +2 6 x1 +1 x2 +1 6 cols +2 .

  if pos( y1, usedChars ) <> 0 then
    rows = 10 || y2

  if pos( x1, usedChars ) <> 0 then
    cols = 10 || x2

RETURN cols rows
</pre>

===Redefine some keys===
<pre>
/* sample code to do some key remapping with ANSI sequences           */
/* see also ANSI ESC Sequences ,                                      */
/* Key codes for key redefinitions and                                */
/* Using function keys                                                */
/*                                                                    */
/* Note: Turning extended keys off is NOT necessary for key     v1.60 */
/*       remapping. This information in RXT&T v1.50 was wrong.  v1.60 */


                        /* set F1 key to HELP<RETURN>                 */
  call CharOut , '1B'x || '[0;59;"HELP";13p'

                        /* set ALT-F10 to EXIT (without RETURN)       */
  call CharOut , '1B'x || '[0;113;"EXIT";p'

                        /* set "A" to ABER (without RETURN)           */
                        /* corrected in RXT&T v1.60                   */
  call CharOut , '1B'x || '[65;"ABER";p'

                        /* reset F1 key to F1                         */
  call CharOut , '1B'x || '[0;59;0;59;p'
</pre>

===Using function keys===
To use function keys without the REXXUTIL functions, redefine them with a trailing CR (see also ANSI ESC Sequences, Key codes for key redefinitions, and download RxLBox for a working example):
<pre>
/* sample key redefinitons                                            */

                    /* new definitons for the function keys           */
  keys.0 = 0
  i = keys.0

  i=i+1; keys.i.__org = '59'; keys.i.__new = 'F1'
  i=i+1; keys.i.__org = '60'; keys.i.__new = 'F2'
  i=i+1; keys.i.__org = '61'; keys.i.__new = 'F3'
  i=i+1; keys.i.__org = '62'; keys.i.__new = 'F4'
  i=i+1; keys.i.__org = '63'; keys.i.__new = 'F5'
  i=i+1; keys.i.__org = '64'; keys.i.__new = 'F6'
  i=i+1; keys.i.__org = '65'; keys.i.__new = 'F7'
  i=i+1; keys.i.__org = '66'; keys.i.__new = 'F8'
  i=i+1; keys.i.__org = '67'; keys.i.__new = 'F9'
  i=i+1; keys.i.__org = '68'; keys.i.__new = 'F10'

  keys.0 = i

                    /* ANSI esc sequence                              */
  ansi.__ESC = '1B'x

                    /* special character to detect function keys      */
  specialChar = 'FE'x

                    /* install error handler for CTRL-BREAK           */
  signal on halt

                    /* redefine the function keys                     */
  do i = 1 to keys.0
    call CharOut , ansi.__ESC || '[0;' || keys.i.__org || ';' || ,
        '"' || specialChar || keys.i.__New || specialChar || '"' || ,
        ';13p'
  end /* do i = 1 to keys.0 */

                    /* test the new key definitons                    */
  do forever
    call LineOut, 'Test the function key redefinitions'
    call CharOut, 'Enter a string (F10 to end): '
    userInput = lineIn()

                    /* test for function keys                         */
    parse var UserInput part1 (specialChar) fKey (specialChar) part2

    UserInput = part1 || part2

    say 'Userinput was: "' || UserInput || '"'

    if fkey = '' then
      say 'No function key pressed.'
    else
      say 'Function key "' || fkey || '" pressed.'

    if fkey = 'F10' then
      leave

  end /* do forever */

ProgramEnd:
                    /* undo the key redefinitons                      */
  do i = 1 to keys.0
    call CharOut , ansi.__ESC || '[0;' || keys.i.__org || ';' || ,
         '0;' || keys.i.__org || ';p'
  end /* do i = 1 to keys.0 */

exit

/* error handler for CTRL-BREAK                                       */

Halt:
  say
  say 'Program aborted by the user!'
  signal ProgramEnd
</PRE>

===Use ANSI for a password input routine===
<pre>
/* sample input routine for passwords using ANSI sequences to hide    */
/* the input (stolen from a message on a public CompuServe forum)     */
/*                                                                    */

  myPassWord = GetPassword( "Please enter the password: " )

  say "You entered the password: " || myPassword

exit

/* ------------------------------------------------------------------ */
/* function: get a password from the user (without showing it on the  */
/*           screen)                                                  */
/*                                                                    */
/* call:     GetPassword( {prompt} )                                  */
/*                                                                    */
/* where:    prompt - prompt string                                   */
/*                    def.: none                                      */
/*                                                                    */
/* returns:  the entered password                                     */
/*                                                                    */
/* note:     This code only works with ANSI enabled                   */
/*                                                                    */
/*                                                                    */
GetPassword: PROCEDURE
  parse arg prompt

                    /* show the prompt (if any) and set the screen    */
                    /* attributes to notvisible                       */
  call CharOut , prompt || "1B"x || "[8m"

                    /* get the user input                             */
  parse pull password
                    /* reset the screen attributes                    */
  call CharOut , "1B"x || "[0m"

RETURN password
</PRE>

===Using the lower right corner of the display===
To print a character to the lower right corner of the screen without scrolling you must turn off the word wrap function of the ANSI driver (see also ANSI ESC Sequences):
<pre>
/* code to show how to use the lower right corner of the display      */

                    /* ESC code for ANSI sequences                    */
  ansi.__ESC = "1B"x

                    /* ANSI sequences to position the cursor in the   */
                    /* upper right corner                             */
  ansi.__Pos0 = ansi.__ESC || "[1;1H"

                    /* ANSI code to turn word wrap off                */
  ansi.__WordWrapOff = ansi.__ESC || "[7l"

                    /* ANSI code to turn word wrap on                 */
  ansi.__WordWrapOn  = ansi.__ESC || "[7h"

                    /* empty line for the menu frame                  */
  Menu.__emptyLine   = "║" || copies( " ", 78 ) || "║"

                    /* separator lines for the menu frame             */
  Menu.__FrameLine1  = copies( "═", 78 )
  Menu.__FrameLine2  = copies( "─", 76 )

                    /* menu frame                                     */
  Menu.__MenuMask = ,
     ansi.__Pos0                          || ,  /* position cursor    */
     ansi.__WordWrapOn                    || ,  /* turn word wrap on! */
     "╔"  || Menu.__FrameLine1 || "╗"     || ,  /* menu frame         */
     Menu.__emptyLine                     || ,
     Menu.__emptyLine                     || ,
     "║ " || Menu.__FrameLine2 || " ║"    || ,
     Menu.__emptyLine                     || ,
     "╠"  || Menu.__FrameLine1 || "╣"     || ,
     copies( Menu.__emptyLine, 14 )       || ,
     "╠"  || Menu.__FrameLine1 || "╣"     || ,
     Menu.__emptyLine                     || ,
     "║ " || Menu.__FrameLine2 || " ║"    || ,
     Menu.__emptyLine                     || ,
     ansi.__WordWrapOff                   || ,  /* turn word wrap off */
     "╚"  || Menu.__FrameLine1 || "╝"     || ,  /* last menu line     */
     ansi.__Pos0                          || ,  /* position cursor    */
     ansi.__WordWrapOn                          /* turn word wrap on  */

                    /* clear the screen                               */
  'cls'
                    /* show the menu frame                            */
  call CharOut , Menu.__MenuMask

                    /* position the cursor in the middle of the       */
                    /* screen                                         */
  call CharOut , ansi.__ESC || "[12;30H"

                    /* wait for a key from the user                   */
  "@pause"
</PRE>

==Date converting==
===Unpack packed data===
Unpack routine from Steve Pitts (see EMail Addresses)
Captured from a message in a public CompuServe Forum
<pre>
/* ------------------------------------------------------------------ */
/* function: unpack routine for packed data (from mainframes)         */
/*                                                                    */
/* call:     unpack packed_str {,num_dec}                             */
/*                                                                    */
/* where:    packed_str = the packed data                             */
/*           num_dec = number of decimals (def.: 0)                   */
/*                                                                    */
/*                                                                    */
/* returns:  the unpacked number or "" in case of an error            */
/*                                                                    */
Unpack: PROCEDURE
  parse arg packed_str, num_dec

  if num_dec = "" then
    num_dec=0

                        /* Convert packed data to hex and split into  */
                        /* number and sign portions                   */
  hex_str=c2x( packed_str )
  dec_str=left( hex_str, length( hex_str )-1 )
  packed_sign=right( hex_str, 1 )

                        /* Check that sign and numeric portions have  */
                        /* valid values                               */
  if verify( packed_sign, "ABCDEF" ) > 0 then
    return ""

  if verify( dec_str, "0123456789" ) > 0 then
    return ""

                        /* Are there enough digits for the decimal    */
                        /* point??                                    */
  if num_dec > length( dec_str ) then
    return ""

                        /* If sign portion indicates a negative       */
                        /* number then oblige                         */
  if pos( packed_sign, "BD" ) > 0 then
    dec_str=0-dec_str

                        /* If there is a decimal point then add it at */
                        /* the appropriate place                      */
  if num_dec > 0 then
    dec_str=insert( ".", dec_str, length( dec_str )-num_dec )

RETURN dec_str
</PRE>

===EBCDIC to ASCII & ASCII to EBCDIC===
captured from a message in a public CompuServe Forum
Author: Dick Goran, (see EMail Addresses)

(see also RXGWA1 - ASCII <-> EBCDIC)

The tables below can be used with the REXX TRANSLATE() instruction:
<pre>
/**********************************************************************/
/*       EBCDIC To ASCII & ASCII To EBCDIC Translate Tables           */
/**********************************************************************/
EBCDIC_OUT = XRANGE(000, 003) ||, /* NUL SOH STX ETX                  */
             XRANGE(055, 055) ||, /* EOT                              */
             XRANGE(045, 047) ||, /* ENQ ACK BEL                      */
             XRANGE(022, 022) ||, /* BS                               */
             XRANGE(005, 005) ||, /* HT                               */
             XRANGE(037, 037) ||, /* LF                               */
             XRANGE(011, 018) ||, /* VT FF CR SO SI DLE DC1 DC2       */
             XRANGE(000, 000) ||, /* DC3                              */
             XRANGE(060, 061) ||, /* DC4 NAK                          */
             XRANGE(050, 050) ||, /* SYN                              */
             XRANGE(038, 038) ||, /* ETB                              */
             XRANGE(024, 025) ||, /* CAN EM                           */
             XRANGE(063, 063) ||, /* SUB                              */
             XRANGE(039, 039) ||, /* ESC                              */
             XRANGE(028, 031) ||, /* FS GS RS US                      */
             XRANGE(090, 090) ||, /* !                                */
             XRANGE(127, 127) ||, /* "                                */
             XRANGE(123, 123) ||, /* #                                */
             XRANGE(091, 091) ||, /* $                                */
             XRANGE(108, 108) ||, /* %                                */
             XRANGE(080, 080) ||, /* &                                */
             XRANGE(125, 125) ||, /* '                                */
             XRANGE(077, 077) ||, /* (                                */
             XRANGE(093, 093) ||, /* )                                */
             XRANGE(092, 092) ||, /* *                                */
             XRANGE(078, 078) ||, /* +                                */
             XRANGE(107, 107) ||, /* ,                                */
             XRANGE(096, 096) ||, /* -                                */
             XRANGE(075, 075) ||, /* .                                */
             XRANGE(097, 097) ||, /* /                                */
             XRANGE(240, 249) ||, /* 0 - 9                            */
             XRANGE(122, 122) ||, /* :                                */
             XRANGE(094, 094) ||, /* ;                                */
             XRANGE(076, 076) ||, /* <                                */
             XRANGE(126, 126) ||, /* =                                */
             XRANGE(110, 110) ||, /* >                                */
             XRANGE(111, 111) ||, /* ?                                */
             XRANGE(124, 124) ||, /* @                                */
             XRANGE(193, 201) ||, /* A - I                            */
             XRANGE(209, 217) ||, /* J - R                            */
             XRANGE(226, 233) ||, /* S - Z                            */
             XRANGE(173, 173) ||, /* [                                */
             XRANGE(224, 224) ||, /* \                                */
             XRANGE(189, 189) ||, /* ]                                */
             XRANGE(095, 095) ||, /* ^                                */
             XRANGE(109, 109) ||, /* _                                */
             XRANGE(121, 121) ||, /* `                                */
             XRANGE(129, 137) ||, /* a - i                            */
             XRANGE(145, 153) ||, /* j - r                            */
             XRANGE(162, 169) ||, /* s - z                            */
             XRANGE(139, 139) ||, /* {                                */
             XRANGE(106, 106) ||, /* |                                */
             XRANGE(155, 155) ||, /* }                                */
             XRANGE(161, 161) ||, /* ~                                */
             XRANGE(007, 007)     /* DEL                              */

 ASCII_OUT = XRANGE(000, 003) ||, /* NUL SOH STX ETX                  */
             XRANGE(000, 000) ||, /* PF                               */
             XRANGE(009, 009) ||, /* HT                               */
             XRANGE(000, 000) ||, /* LC                               */
             XRANGE(127, 127) ||, /* DEL                              */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /* SMM                              */
             XRANGE(011, 018) ||, /* VT CR SO SI DLE DC1 DC2          */
             XRANGE(000, 000) ||, /* TM                               */
             XRANGE(000, 000) ||, /* RES                              */
             XRANGE(000, 000) ||, /* NL                               */
             XRANGE(008, 008) ||, /* BS                               */
             XRANGE(000, 000) ||, /* IL                               */
             XRANGE(024, 025) ||, /* CAN EM                           */
             XRANGE(000, 000) ||, /* CC                               */
             XRANGE(000, 000) ||, /* CU1                              */
             XRANGE(028, 031) ||, /* FS GS RS US                      */
             XRANGE(000, 000) ||, /* DS                               */
             XRANGE(000, 000) ||, /* SOS                              */
             XRANGE(028, 028) ||, /* FS                               */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /* BYP                              */
             XRANGE(010, 010) ||, /* LF                               */
             XRANGE(023, 023) ||, /* ETB                              */
             XRANGE(027, 027) ||, /* ESC                              */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /* SM                               */
             XRANGE(000, 000) ||, /* CU2                              */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(005, 007) ||, /* ENQ ACK BEL                      */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(022, 022) ||, /* SYN                              */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /* PN                               */
             XRANGE(000, 000) ||, /* RS                               */
             XRANGE(000, 000) ||, /* UC                               */
             XRANGE(004, 004) ||, /* EOT                              */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /* CU3                              */
             XRANGE(020, 020) ||, /* DC4                              */
             XRANGE(021, 021) ||, /* NAK                              */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(026, 026) ||, /* SUB                              */
             XRANGE(032, 032) ||, /* space                            */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /* cent sign                        */
             XRANGE(046, 046) ||, /* .                                */
             XRANGE(060, 060) ||, /* <                                */
             XRANGE(040, 040) ||, /* (                                */
             XRANGE(043, 043) ||, /* +                                */
             XRANGE(033, 033) ||, /* |                                */
             XRANGE(038, 038) ||, /* &                                */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(033, 033) ||, /* !                                */
             XRANGE(036, 036) ||, /* $                                */
             XRANGE(042, 042) ||, /* *                                */
             XRANGE(041, 041) ||, /* )                                */
             XRANGE(059, 059) ||, /* ;                                */
             XRANGE(000, 000) ||, /* not symbol                       */
             XRANGE(045, 045) ||, /* -                                */
             XRANGE(047, 047) ||, /* /                                */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(124, 124) ||, /* |                                */
             XRANGE(044, 044) ||, /* ,                                */
             XRANGE(037, 037) ||, /* %                                */
             XRANGE(095, 095) ||, /* _                                */
             XRANGE(062, 062) ||, /* >                                */
             XRANGE(063, 063) ||, /* ?                                */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(096, 096) ||, /* `                                */
             XRANGE(058, 058) ||, /* :                                */
             XRANGE(035, 035) ||, /* #                                */
             XRANGE(064, 064) ||, /* @                                */
             XRANGE(039, 039) ||, /* '                                */
             XRANGE(061, 061) ||, /* =                                */
             XRANGE(034, 034) ||, /* "                                */
             XRANGE(097, 105) ||, /* a - i                            */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(106, 114) ||, /* j - r                            */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(126, 126) ||, /* ~                                */
             XRANGE(115, 122) ||, /* s - z                            */
             COPIES(192 - 170, D2C(0)) ||,
             XRANGE(123, 123) ||, /* {                                */
             XRANGE(065, 073) ||, /* A - I                            */
             COPIES(209 - 202, D2C(0)) ||,
             XRANGE(074, 082) ||, /* J - R                            */
             COPIES(224 - 218, D2C(0)) ||,
             XRANGE(092, 092) ||, /* \                                */
             XRANGE(000, 000) ||, /*                                  */
             XRANGE(083, 090) ||, /* S - Z                            */
             COPIES(240 - 234, D2C(0)) ||,
             XRANGE(048, 057) ||, /* J - R                            */
             COPIES(256 - 250, D2C(0))
</pre>

===Uppercase & Lowercase including German "Umlaute"===
<PRE>
/* sample code to translate a string to uppercase or lowercase which  */
/* also handles the German "Umlaute"                                  */
/* Note that there's an country-dependent uppercase translation v1.80 */
/* routine in the new REXXUTIL DLL. Object-Oriented REXX             */
    say "Lower() " lower( "AbcdEF Ö Ä Ü ß 1234567890" )
    say "Upper() " upper( "aBcDef ö ä ü ß 1234567890" )
exit

/* ------------------------------------------------------------------ */
/* function: Convert a char or string to uppercase                    */
/*                                                                    */
/* call:     Upper string                                             */
/*                                                                    */
/* where:    string - string to convert                               */
/*                                                                    */
/* returns:  the converted string                                     */
/*                                                                    */
/* note:     This implementation handles German "Umlaute"             */
/*                                                                    */
Upper: PROCEDURE
  parse arg thisString

RETURN translate( thisString, "ABCDEFGHIJKLMNOPQRSTUVWXYZÄÖÜß" ,,
                              "abcdefghijklmnopqrstuvwxyzäöüß" )

/* ------------------------------------------------------------------ */
/* function: Convert a char or string to lowercase                    */
/*                                                                    */
/* call:     Lower string                                             */
/*                                                                    */
/* where:    string - string to convert                               */
/*                                                                    */
/* returns:  the converted string                                     */
/*                                                                    */
/* note:     This implementation handles German "Umlaute"             */
/*                                                                    */
Lower: PROCEDURE
  parse arg thisString

RETURN translate( thisString,  "abcdefghijklmnopqrstuvwxyzäöüß" ,,
                               "ABCDEFGHIJKLMNOPQRSTUVWXYZÄÖÜß" )
</PRE>

===Date converting routine - 1 -===
Captured from a message in a public CompuServe Forum

Note from the author from the PL/1 version

Julian (sense 1) date routines, handling Julian (sense 2) and Gregorian calendars. Algorithm is valid from 4713 B.C. to 19,999 A.D. This version is known to be free of errors.

Based on Pascal code copyright 1985 by Michael A. Covington, published in P.C. Tech Journal, December 1985, based on formulae appearing in Astronomical Formulae for Calculators by Jean Meeus. Reconversion to normal Julian epoch, integer arithmetic, 4000-year correction, and translation to PL/I by John W. Kennedy

Historical exceptions _not_ allowed for in this module:
Until Julius Caesar established the Julian calendar in 45 B.C., calendars were irregular.
This module assumes the Julian calendar back to 4713 B.C.
The Julian calendar was altered in 8 B.C. From 45 B.C. to 8 B.C., the months were Jan=31, Feb=29(30), Mar=31, Apr=30, May=31, Jun=30, Jul=31, Aug=30, Sep=31, Oct=30, Nov=31, Dec=30
This module assumes the month lengths as we know them. Leap years from 45 B.C. to 8 A.D. were miscalculated: (45, 42, 39, 36, 33, 30, 27, 24, 21, 18, 15, 12, 9, then none at all until 8 A.D.) This module assumes leap years every four years, as they were meant to have been. January 1 was not always the first day of the year. The United Kingdom, in particular, started the year on March 25 until 1752. (However, the year ended on December 31, leaving the days between in limbo.) This module assumes January 1 is the first day of the year. Leap-year day was originally done by having February 24 (25 from 45 to 8 B.C.) twice. This module assumes Leap-year day is February 29.

The "Transition" argument is the first Julian date to be considered as belonging to the Gregorian calendar. Usual values are:
2299161 = October 5/15, 1582, as in Rome, or 2361222 = September 3/14, 1752, as in the United Kingdom and the American colonies
<PRE>
/* sample routines to convert dates                                   */

  call Charout , "Enter a date in the format dd.mm.yyyy: "
  curDMYDate = lineIn()

  curJulianDate = DMYToJulian( curDMYDate )
  say "DMYToJulian(" || curDMYDate || ") is " || curJulianDate

  say "JulianToDMY(" || curJulianDate || ") is " || ,
      JulianToDMY( curJulianDate )

exit 0

/* ------------------------------------------------------------------ */
/* function: Convert a date from Julian to DMY                        */
/*                                                                    */
/* call:     JulianToDMY julianDate {trans}                           */
/*                                                                    */
/* where:    julianDate - the date in julian format                   */
/*           trans - see note above                                   */
/*                                                                    */
/* returns:  the date in the format dd.mm.yyyy                        */
/*                                                                    */
/*                                                                    */
JulianToDMY: PROCEDURE
  Arg J Trans

  if Trans = "" then
    Trans = 2299161

  if J < Trans then
    A = J
  Else
  do
    AA = J - 1721120
    AC = Trunc(AA / 1460969)
    AB = 31 * AC
    AA = AA - AC * 1460969
    AC = Trunc(AA / 146097)
    AB = AB + 3 * AC
    AA = AA - AC * 146097
    if AA = 146096 then
      AB = AB + 3
    Else
      AB = AB + Trunc(AA / 36524)
    A = J + (AB - 2)
  end
  B = A + 1524
  C = Trunc((20 * B - 2442) / 7305)
  D = Trunc(1461 * C / 4)
  EE = B - D
  E = Trunc(10000 * EE / 306001)
  YMDD = EE - Trunc(306001 * E / 10000)
  if E >= 14 then
    YMDM = E - 13
  else
    YMDM = E - 1
  if YMDM > 2 then
    Y = C - 4716
  else
    Y = C - 4715
  if Y < 1 then
    YMDY = Y - 1
  else
    YMDY = Y

RETURN YMDD || '.' || YMDM || '.' || YMDY

/* ------------------------------------------------------------------ */
/* function: Convert a date from DMY to Julian                        */
/*                                                                    */
/* call:     DMYToJulian dmyDate {trans}                              */
/*           trans - see note above                                   */
/*                                                                    */
/* where:    dmyDate - the date in the format dd.mm.yyyy              */
/*                                                                    */
/* returns:  the date in Julian format                                */
/*                                                                    */
/*                                                                    */
DMYToJulian: PROCEDURE
  parse arg dmyDate trans

  parse var dmyDate YMDD "." YMDM "." YMDY

  if Trans = "" then
    Trans = 2299161

  AY = YMDY
  if YMDY < 0 then
    Y = YMDY + 4717
  else
    Y = YMDY + 4716
  if YMDM < 3 then
  do
    M = YMDM + 12
    Y = Y - 1
    AY = AY - 1
  end
  else
    M = YMDM
  D = Trunc((1461 * Y) / 4) + Trunc((153 * (M + 1)) / 5) + YMDD - 1524
  G = D + 2 - Trunc(AY / 100) + Trunc(AY / 400) - Trunc(AY / 4000)
  if G >= Trans then
    thisRC = G
  else
    thisRC = D

RETURN thisRC
</PRE>

===Date converting routine - 2 -===
<PRE>
/* sample routine to convert a date in the format dd/mm/yy into the   */
/* base date format                                                   */
/*                                                                    */
/* Description from the author:                                       */
/*   routine to convert a date passed in YY/MM/DD format (assumes the */
/*   date is 19YY/MM/DD ) to Base date format which is based upon an  */
/*   imaginary calendar date of 1/1/0001 it then assumes there is a   */
/*   leap year every 4 years and every 400 years but not if the year  */
/*   is divisble by 100                                               */
/*                                                                    */
/* Note: I do NOT know the author of this code.                       */
/*       I found this code on an IBM BBS.                             */
/*                                                                    */

  do forever
    say ""
    say "Test the routine CalcBaseDate against the REXX function date"
    say "  Note that the REXX function date only handles dates AFTER"
    say "  the 01.01.1980!"
    say "Enter a date to convert (dd.mm.yy, RETURN to end):"
    testDate = strip( lineIn() )

    if testDate = "" then
      leave

    say "  result of CalcBaseDate( """ || testDate || """) is: " || ,
         CalcBaseDate( testDate )

                        /* save the current date                      */
    oldDate = date( "E" )

                        /* set the current date to the testdate to    */
                        /* test the routine CalcBaseDate against the  */
                        /* REXX function date( B )                    */
    "@date " testDate
    say "  result of the REXX function date( ""B"" ) is: " || ,
         date( "B" )

                        /* restore the current date                   */
    "@date " oldDate
  end /* do forever */
exit 0

/* ------------------------------------------------------------------ */
/* function: Convert a date in the format dd.mm.yy into the base date */
/*           format                                                   */
/*                                                                    */
/* usage:    CalcBaseDate dateToConvert                               */
/*                                                                    */
/* where:    dateToConvert - date to convert in the format dd.mm.yy   */
/*                                                                    */
/* returns:  the date in base date format                             */
/*                                                                    */
CalcBaseDate: PROCEDURE

                        /* initialize routine                         */
  NonLeap.   = 31
  NonLeap.0  = 12
  NonLeap.2  = 28
  NonLeap.4  = 30
  NonLeap.6  = 30
  NonLeap.9  = 30
  NonLeap.11 = 30

                /* grab parameter and store it in cyear cmonth cdate  */
  parse arg cdate "." cmonth "." cyear .

                /* grab year and convert it to YYYY                   */
                /* simulate the behaviour of the REXX function date() */
  if length( cyear ) <= 2 then
    if cyear < 80 then
      fullyear = "20" || cyear
    else
      fullyear = "19" || cyear
  else
    fullyear = cyear

  numyears = fullyear -1
  basedays = numyears * 365
  QuadCentury = numyears % 400
  Century = numyears % 100
  LeapYears = numyears % 4
  basedays = basedays + (((LeapYears - Century) + QuadCentury) - 1)

  do i = 1 to (cmonth -1)
    if i <> "2" then
      basedays = basedays + NonLeap.i
    else /* find if it's a leap year or not */
      if (fullyear // 4) > 0 then
        basedays=basedays + 28
      else
        if ((fullyear // 100) = 0) & ((fullyear // 400) > 0) then
        do
                        /* century not divisble by 400                */
          basedays = basedays + 28
        end /* if */
        else
        do
                        /* quad century or regular leap year          */
          basedays = basedays + 29
        end /* else */
  end /* do */

  basedays = basedays + cdate
return basedays
</PRE>

===Convert values from/to INTEL format===
On Intel processors words and doublewords are saved in the so-called INTEL format (LSB - last signifcant byte first). To use them, you must convert them into the MSB format (MSB - most significant byte first).
Before using the following routine, you must convert the value into a hex string (see Get the display resolution for an example).
<PRE>
/* ------------------------------------------------------------------ */
/* function: Convert an WORD or DWORD from LSB format to MSB format   */
/*           and vice versa                                           */
/*                                                                    */
/* call:     LSB2MSB inputHexString                                   */
/*                                                                    */
/* where:    inputHexstring - input value as hexstring                */
/*                            (e.g. "3412", "78563412")               */
/*                                                                    */
/* output:   value in MSB format as hexstring                         */
/*           (e.g. "1234", "12345678")                                */
/*                                                                    */
LSB2MSB: PROCEDURE
  HexZiffer = arg(1)                                         /* v3.00 */
  Len = Length(HexZiffer)                                    /* v3.00 */
  If (Len // 2) then                                         /* v3.00 */
     HexZiffer = Right(HexZiffer, Len + 1, '0')              /* v3.00 */
  RETURN strip( translate( "12345678",,                      /* v3.00 */
                           HexZiffer, "78563412" ) )         /* v3.00 */
</PRE>

===Formatting numbers===
<PRE>
/* sample routine to format a number into the format                  */
/*  nnn.nnn.nnn                                                       */
/* and vice versa                                                     */
/*                                                                    */
/* Source: I found routines of this type in various messages on the   */
/*         IBM REXX forums                                            */
/*         (see also EdmREXX - misc. functions for REXX)              */
/*                                                                    */
  do forever

    call CharOut , "Enter a number (RETURN to end): "
    thisNumber = lineIn()
    if thisNumber = "" then
      leave
    else
    do
      thatNumber = FormatNumber( thisNumber )
      call LineOut , "Result of FormatNumber( " || thisNumber || " ) is " ,
                     thatNumber

      call LineOut , "Result of UnFormatNumber( " || thatNumber || " ) is " ,
                     UnFormatNumber( thatNumber )
    end /* else */
  end /* do forever */

exit

/* ------------------------------------------------------------------ */
/* function: Format a number like 123456789.44 into the format        */
/*           123,456,789.44                                           */
/*                                                                    */
/* call:     FormatNumber number_to_format                            */
/*                                                                    */
/* where:    number_to_format                                         */
/*                                                                    */
/* returns:  the formatted number                                     */
/*                                                                    */
/* note:     works for all numbers up to (but not including)          */
/*           1.000,000,000,000,000.0                                  */
/*                                                                    */
/* Author:   Graham Ewart                                             */
/*                                                                    */
FormatNumber: PROCEDURE expose (exposeList)
  parse value arg(1) with whole "." decs

  formattedNumber = strip( reverse( translate( "abc,def,ghi,jkl,mno",,
                                   reverse(whole),,
                                   "abcdefghijklmno",",")),"L",",")

  if decs <> "" then
    formattedNumber = formattedNumber || "." || decs
RETURN formattedNumber

/* ------------------------------------------------------------------ */
/* function: Unformat a number like 123,456,789.44 into the format    */
/*           123456789.44                                             */
/*                                                                    */
/* call:     UnFormatNumber number_to_unformat                        */
/*                                                                    */
/* where:    number_to_unformat                                       */
/*                                                                    */
/* returns:  the unformatted number                                   */
/*                                                                    */
/* note:     works for all numbers                                    */
/*                                                                    */
UnFormatNumber: PROCEDURE

RETURN space( translate( arg(1), " ", "," ) , 0, )
</PRE>

===Convert ASCII 850 string into/from ISO 8859-1 (1004) string===
<PRE>
/* ------------------------------------------------------------------ */
/* function: Convert an ASCII 850 string into an ISO 8859-1           */
/*           (1004) string and vice versa                             */
/*                                                                    */
/* call:     PC_ISOB thisString, outP                                 */
/*                                                                    */
/* where:    thisString - the string to convert                       */
/*           outP - function code, either                             */
/*                    1004 to convert to ISO                          */
/*                  or                                                */
/*                     850 to convert to ASCII                        */
/*                                                                    */
/* output:   the converted string                                     */
/*                                                                    */
/* Notes:    Note that this not a complete codepage conversion.       */
/*           We only care about the letters.                          */
/*                                                                    */
/* Author:   Oliver Heidelbach (see EMail Addresses)                  */
/*                                                                    */
PC_ISO: PROCEDURE

  PARSE ARG thisString, outp

  aISO = 'a1 a2 a3 bf c0 c1 c2 c3 c4 c5 c6 c7 c8 c9 ca cb cc cd ce cf d0',
         'd1 d2 d3 d4 d5 d6 d8 d9 da db dc dd de df e0 e1 e2 e3 e4 e5 e6',
         'e7 e8 e9 ea eb ec ed ee ef f0 f1 f2 f3 f4 f5 f6 f8 f9 fa fb fc',
         'fd fe ff'

  aPC =  'ad bd 9c a8 b7 b5 b6 c7 8e 8f 92 80 d4 90 d2 d3 de d6 d7 d8 d1',
         'a5 d2 d3 d4 e5 99 d8 eb e9 ea 9a ed e8 e1 85 a0 83 c6 84 86 91',
         '87 8a 82 88 89 8d a1 8c 8b d0 a4 95 a2 93 e4 94 9b 97 a3 96 81',
         'ec e7 98'

  if outp = 1004 then
    convbuf = Translate(thisString, X2C(aISO), X2C(aPC))
  else
    if outp = 850 then
      convbuf = Translate(thisString, X2C(aPC), X2C(aISO))

RETURN convbuf
</PRE>

===Convert Microsoft/IEEE Float binary into a string in Classic REXX===
(see also Convert Microsoft/IEEE Float binary into a string in Object REXX)
<PRE>
/**********************************************************************/
/* These routines are the original work of Thos Davis                 */
/* (see EMail Addresses)                                              */
/* and to the best of his knowledge do not include any copyrighted    */
/* materials.                                                         */
/*                                                                    */
/* These routines are hereby released into the Public Domain          */
/**********************************************************************/
/* Microsoft/IEEE Float binary:                                       *
  +--------------------------------------------------------------------+
  |bit |0 1 2 3 4 5 6 7 8 9 A B C D E F 0 1 2 3 4 5 6 7 8 9 A B C D E F|
  +====+=============================================+=+===============+
  |MKS |              mantissa                       |s|   exponent    |
  +----+---------------------------------------------+-+-------------+-|
  |IEEE|              mantissa                       |    exponent   |s|
  +--------------------------------------------------+---------------+-+
                                                                      */
/* In both cases, the mantissa is the lower (least significant)       */
/* 23 bits (plus an implied value of 1 for bit 24, the most           */
/* significant bit of the mantissa), the sign is one bit, and         */
/* the exponent is 8 bits.                                            */
/*                                                                    */
/* Because the mantissa has a 'virtual bit' whose value is always 1,  */
/* the exponent is used to determine if the value is 0.               */
/*                                                                    */
/* IEEE Double Float binary is the same format as the single Float    */
/* but the mantissa is 52 bits long (for 53 bits of significant       */
/* binary digits [is that bigits?] after including the 'virtual 1'    */
/* most significant bit) and the exponent is 11 bits long.            */
/*                                                                    */
/* !!! I M P O R T A N T !!!                                          */
/*                                                                    */
/* NUMERIC DIGITS should be set to about 16 to get the full value of  */
/* Doubles. If these procedures are made into ROUTINES, it will be    */
/* necessary to add the NUMERIC DIGITS setting to DoubleToString and  */
/* GeneralFloat.                                                      */
/*                                                                    */
/* !!! A L S O   I M P O R T A N T !!!                                */
/*                                                                    */
/* These functions do not recognize the special values                */
/*    +INF    plus infinity                                           */
/*    -INF    minus infinity                                          */
/*    +NAN    not a number                                            */
/*    -NAN    not a number                                            */
/*                                                                    */

mksToString: procedure
  TheFloat = arg(1)

                    /* mks is the format used in older versions of    */
                    /* MicroSoft BASIC and is, for some bizarre       */
                    /* reason, used as the index value in the QWK     */
                    /* BBS message packing scheme                     */

                    /* Intel uses different BYTE ordering and BIT     */
                    /* ordering so byte strings must be REVERSED to   */
                    /* make all ordering the same                     */
    bFloat = Reverse( TheFloat )

                    /* There is no c2b function                       */
    bFloat = x2b( c2x( bFloat ) )

                    /* make sure its 32 bits long                     */
    bFloat = Right( bFloat, 32, '0' )
    fMantissa = '1' || Right( bFloat, 23 )
    fExponent = Left( bFloat, 8 )
    fSign = SubStr( bFloat, 9, 1 )

                    /* I found the magicNumber values by trial and    */
                    /* error                                          */
    magicNumber = 152

return GeneralFloat( fSign, fMantissa, fExponent, magicNumber )


FloatToString: procedure
  TheFloat = arg(1)

    bFloat = Reverse( TheFloat )
    bFloat = x2b( c2x( bFloat ) )
    bFloat = Right( bFloat, 32, '0' )
    fMantissa = '1' || Right( bFloat, 23 )
    fExponent = SubStr( bFloat, 2, 8 )
    fSign = Left( bFloat, 1 )
    magicNumber = 150
return GeneralFloat( fSign, fMantissa, fExponent, magicNumber )


DoubleToString: procedure
  TheDouble = arg(1)

    bDouble = Reverse( TheDouble )
    bDouble = x2b( c2x( bDouble ) )
    bDouble = Right( bDouble, 64, '0' )
    dMantissa = '1' || Right( bDouble, 52 )
    dExponent = SubStr( bDouble, 2, 11 )
    dSign = Left( bDouble, 1 )
    magicNumber = 1075
return GeneralFloat( dSign, dMantissa, dExponent, magicNumber )


GeneralFloat: procedure
  theSign = arg(1)
  theMantissa = arg(2)
  theExponent = arg(3)
  magicNumber = arg(4)

    if theExponent = 0 then
        ascFloat = 0
    else
      do
        decMantissa = x2d( b2x( theMantissa ) )
        decExponent = x2d( b2x( theExponent ) )
        ascFloat = decMantissa * ( 2 ** ( decExponent - magicNumber ))
      end

    if theSign then
        ascFloat = '-'ascFloat

return ascFloat
</PRE>

====AN ADDENDUM====
While converting from binary fractions to decimal fractions has some inherent inaccuracies, the REXX procedures I gave have some additional ones built in. REXX does not use binary arithmetic (at least it is not supposed to). Instead it uses decimal methods modelled on human arithmetic systems. This gives better results for decimal numbers, but tends to make arithmetic with binary fractions somewhat less accurate.

Because of this, and because I use arithmetic on the numbers when converting, _sometimes_ 'conversion artefacts' will be introduced which result in a representation slightly greater or less than the value which is returned by standard C library functions (e.g. printf()). For example 0.5 decimal (1/2), which is 0.1 binary, should translate perfectly from one system to the other, will be translated from the double to 0.5000000000000002 using DoubleToString. Likewise 0.0625 decimal (1/16), which is 0.0001 binary, is translated as 0.06250000000000001.

Additionally, the results are dependent on the value of NUMERIC DIGITS. For example: 1.0 is translated by FloatToString() as 0.99999999999 when NUMERIC DIGITS is set to 11 (decimal), and 0.5 (decimal) is translated by DoubleToString as 0.49999999999999999999 when NUMERIC DIGITS is 20.

It is important to note that the actual value stored in the file is not changed.

If it is important to see very precise translations, these procedures may not be for you. However, with the information on the format of the numbers, you may be able to devise your own conversion procedures.

Additionally, I did not include the IEEE +INFINITY, -INFINITY, +NOT-A-NUMBER, and -NOT-A-NUMBER, because I do not have documentation on these values. However, based on actual conversions by Borland's C++ for OS/2 (version 1.5), I am led to believe that an exponent whose bits are all set to 1 indicates a SPECIAL VALUE. If the exponent is all ones, and the mantissa (with the virtual bit) has only its most significant bit set to 1, then that is INFINITY (+/- depending on the sign), and if the two most significant bits (including the virtual bit) are both set to 1 and no other bits in the mantissa are set to 1, then that is NOT-A-NUMBER. If the other bits are set to 1, I don't know what that means.

I use a test for the special exponent in my own routines (I use ObjectREXX) and then call SpecialFloat if it matches. If you use this type of procedure, then it may be necessary for your program to test for these values before performing additional math on them! I do not know if the Microsoft Format used by early versions of BASIC has any special values.
<pre>
::ROUTINE FloatToString PUBLIC
    ...

    if fExponent = '11111111' then
      return SpecialFloat( fSign, fMantissa, 'S' )
    else
      return GeneralFloat( ... )


::ROUTINE SpecialFloat
  use arg theSign, theMantissa, theType

    SELECT
      WHEN theType = 'S' then lenMantissa = 24
      WHEN theType = 'D' then lenMantissa = 53
    END

    SELECT
      WHEN theMantissa = '1'~Left( lenMantissa, '0' ) THEN
        ieeeSpecial = 'INFINITY'
      WHEN theMantissa = '11'~Left( lenMantissa, '0' ) THEN
        ieeeSpecial = 'NOT-A-NUMBER'
      OTHERWISE
        ieeeSpecial = 'UNKNOWN-MEANING'
    END /* SELECT */

    if theSign then
      ieeeSpecial = '-'ieeeSpecial
    else
      ieeeSpecial = '+'ieeeSpecial

    return 'IEEE:' ieeeSpecial
</PRE>

===Convert Microsoft/IEEE Float binary into a string in Object REXX===
(see also Convert Microsoft/IEEE Float binary into a string in Classic REXX; especially the addendum)
<PRE>
/**********************************************************************/
/* These routines are the original work of Thos Davis                 */
/* (see EMail Addresses)                                              */
/* and to the best of his knowledge do not include any copyrighted    */
/* materials.                                                         */
/*                                                                    */
/* These routines are hereby released into the Public Domain          */
/**********************************************************************/
/* Microsoft/IEEE Float binary:                                       *
 +--------------------------------------------------------------------+
 |bit |0 1 2 3 4 5 6 7 8 9 A B C D E F 0 1 2 3 4 5 6 7 8 9 A B C D E F|
 +====+=============================================+=+===============+
 |MKS |              mantissa                       |s|   exponent    |
 +----+---------------------------------------------+-+-------------+-|
 |IEEE|              mantissa                       |    exponent   |s|
 +--------------------------------------------------+---------------+-+
                                                                      */
/* In both cases, the mantissa is the lower (least significant)       */
/* 23 bits (plus an implied value of 1 for bit 24, the most           */
/* significant bit of the mantissa), the sign is one bit, and         */
/* the exponent is 8 bits.                                            */
/*                                                                    */
/* Because the mantissa has a 'virtual bit' whose value is always 1,  */
/* the exponent is used to determine if the value is 0.               */
/*                                                                    */
/* IEEE Double Float binary is the same format as the single Float    */
/* but the mantissa is 52 bits long (for 53 bits of significant       */
/* binary digits [is that bigits?] after including the 'virtual 1'    */
/* most significant bit) and the exponent is 11 bits long.            */
/*                                                                    */
/* !!! I M P O R T A N T !!!                                          */
/*                                                                    */
/* NUMERIC DIGITS should be set to about 16 to get the full value of  */
/* Doubles                                                            */
/*                                                                    */
/* !!! A L S O   I M P O R T A N T !!!                                */
/*                                                                    */
/* These functions may not correctly recognize the special values     */
/*    +INF    plus infinity                                           */
/*    -INF    minus infinity                                          */
/*    +NAN    not a number                                            */
/*    -NAN    not a number                                            */
/*                                                                    */

::ROUTINE mksToString PUBLIC
  use arg TheFloat

                    /* mks is the format used in older versions of    */
                    /* MicroSoft BASIC and is, for some bizarre       */
                    /* reason, used as the index value in the QWK     */
                    /* BBS message packing scheme                     */

  if TheFloat~Length \= 4 then
    return 'NOT-A-FLOAT'

    bFloat = TheFloat~Reverse~c2x~x2b~Right(32,'0')
    fMantissa = '1' || bFloat~Right(23)
    fExponent = bFloat~Left( 8 )
    fSign = bFloat~SubStr( 9, 1 )
    magicNumber = 152
    return GeneralFloat( fSign, fMantissa, fExponent, magicNumber, Digits() )


::ROUTINE FloatToString PUBLIC
  use arg TheFloat

  if TheFloat~Length \= 4 then
    return 'NOT-A-FLOAT'

    bFloat = TheFloat~Reverse~c2x~x2b~Right(32,'0')
    fMantissa = '1' || bFloat~Right(23)
    fExponent = bFloat~SubStr( 2, 8 )
    fSign = bFloat~Left(1)
    magicNumber = 150

                    /* IS SPECIAL VALUE                               */
    if fExponent = '11111111' then
      return SpecialFloat( fSign, fMantissa, 'S' )
    else
      return GeneralFloat( fSign, fMantissa, fExponent, magicNumber, Digits() )


::ROUTINE DoubleToString PUBLIC
  use arg TheDouble
  NUMERIC DIGITS 16

  if TheFloat~Length \= 8 then
    return 'NOT-A-FLOAT'

    bDouble = TheDouble~Reverse~c2x~x2b~Right(64,'0')
    dMantissa = '1' || bDouble~Right(52)
    dExponent = bDouble~SubStr( 2, 11 )
    dSign = bDouble~Left(1)
    magicNumber = 1075

                    /* IS SPECIAL VALUE                               */
    if dExponent = '11111111111' then
      return SpecialFloat( dSign, dMantissa, 'D' )
    else
      return GeneralFloat( dSign, dMantissa, dExponent, magicNumber, Digits() )


::ROUTINE GeneralFloat
  use arg theSign, theMantissa, theExponent, magicNumber, numdigits
  NUMERIC DIGITS numdigits

    if theExponent = 0 then
        ascFloat = 0
    else
        ascFloat = (theMantissa~b2x~x2d) * ( 2 ** ( (theExponent~b2x~x2d) - magicNumber ))

    if theSign then
        ascFloat = '-'ascFloat

    return ascFloat


::ROUTINE SpecialFloat
  use arg theSign, theMantissa, theType

    SELECT
      WHEN theType = 'S' then lenMantissa = 24
      WHEN theType = 'D' then lenMantissa = 53
    END

    SELECT
      WHEN theMantissa = '1'~Left( lenMantissa, '0' ) THEN
        ieeeSpecial = 'INFINITY'
      WHEN theMantissa = '11'~Left( lenMantissa, '0' ) THEN
        ieeeSpecial = 'NOT-A-NUMBER'
      OTHERWISE
        ieeeSpecial = 'UNKNOWN-MEANING'
    END /* SELECT */

    if theSign then
      ieeeSpecial = '-'ieeeSpecial
    else
      ieeeSpecial = '+'ieeeSpecial

    return 'IEEE:' ieeeSpecial
</PRE>

====Determine what day of the week a date falls on====
<PRE>

 
/* sample code to determine what day of the week a date falls on      */
/*                                                                    */
/* Source: Found in a message in a public news group                  */
/*                                                                    */

  do forever
    say 'Enter the date in the format dd.mm.yyyy (<return> to exit):'
    thisDate = strip( translate( lineIn() ) )
    if thisDate = '' then
      leave
    say 'The day of the week for the ' || thisDate || ,
        ' is: ' || dayOfTheWeek( thisDate )
  end /* do forever */
exit

/* ------------------------------------------------------------------ */
/* function: Determine what day of the week a date falls on           */
/*                                                                    */
/* call:     dayOfTheWeek = DayOfTheWeek( thisDate )                  */
/*                                                                    */
/* where:    thisDate - date in the format dd.mm.yyyy                 */
/*                                                                    */
/* returns:  the name of the day or ERROR in case of an error         */
/*                                                                    */
/*                                                                    */
DayOfTheWeek: PROCEDURE

                    /* install a local error handler                  */
  signal on syntax name DayOfTheWeekError

  sep = '.'
  parse arg dd (sep) mm (sep) year

  days = "Sunday Monday Tuesday Wednesday Thursday Friday Saturday"
  magic = 6 2 3 6 1 4 6 2 5 0 3 5
  parse var year cent +2 yr
  leap = year // 4 = 0 & (yr\=0 | cent//4=0)
  dow=yr + yr%4 + (6-2*(cent//4)) + word(magic,mm) + dd
  if mm < 3 & \leap then
    dow=dow+1
  dow = dow // 7
return word(days,dow+1)

DayOfTheWeekError:
  return 'ERROR'
</PRE>

==Input & Output==
===Simulate the BASIC INPUT command===
<PRE>
/* example for simulating the input command used in BASIC             */

                        /* example call ...                           */
  thisString = input( "Enter a string: " )
  say "You entered '" || thisString || "'."

exit

/* ------------------------------------------------------------------ */
/* function: Simulate the BASIC command INPUT                         */
/*                                                                    */
/* call:     input( prompt )                                          */
/*                                                                    */
/* where:    prompt - prompt for the input                            */
/*                                                                    */
/* returns:  entered string                                           */
/*                                                                    */
Input: PROCEDURE
  parse arg prompt

  if prompt = "" then
    prompt = "Your Input:"

                         /* set word wrap off                         */
  call CharOut , "1B"x || "[7l"

                         /* show the prompt string                    */
  call charOut , prompt || " "

                         /* get the user input                        */
  thisRC = lineIn()

                         /* set word wrap on again                    */
  call CharOut , "1B"x || "[7h"

RETURN thisRC
</PRE>

===Simple Yes/No question===
<PRE>
/* example for a simple yes/no question without loading the dll       */
/* REXXUTIL                                                           */

                        /* example call ...                           */
  thisKey = AskUser( "YN", "Enter Y or N: " )
  say "You entered '" || thisKey || "'."

exit

/* ------------------------------------------------------------------ */
/* AskUser - get input from the user                                  */
/*                                                                    */
/* Usage:    AskUser akeys, prompt                                    */
/*                                                                    */
/* where:                                                             */
/*           akeys - allowed keys (all keys are translated to         */
/*                   uppercase)                                       */
/*           prompt - prompt for the ask                              */
/*                                                                    */
/* Returns:  the pressed key in uppercase                             */
/*                                                                    */
/* note:     This routine uses ESC sequences to position the cursor.  */
/*           This routine only works if you do not use the            */
/*           last line of the screen for the prompt!                  */
/*                                                                    */
AskUser: PROCEDURE
  parse arg aKeys, prompt

  aKeys = translate( akeys )

                         /* set word wrap off                         */
  call CharOut , "1B"x || "[7l"

  if prompt <> "" then
    call charout ,  prompt

  thisKey = " "
  do UNTIL pos( thisKey ,  aKeys ) <> 0
    call charOut ,"1B"x || "[s" || "1B"x || "[K"
    thisKey = translate( charIn() )
    call CharOut , "1B"x || "[u"
                        /* delete the CR/LF sequence from             */
                        /* the keyboard buffer!                       */
    dummy = lineIn()

  end /* do until ... */

                         /* set word wrap on again                    */
  call CharOut , "1B"x || "[7h"

                        /* do a linefeed                              */
  say ""

RETURN thisKey
</PRE>

===Choice routine for REXX===
<PRE>
/* sample choice routine with timeout                                 */

                        /* load REXXUTIL                              */
 call rxFuncAdd "SysLoadFuncs", "REXXUTIL", "SysLoadFuncs"
 call SysLoadFuncs

                        /* default key if no key is pressed           */
 thisDefault= "Y"
                        /* timeout value in seconds                   */
 thisTimeOut = 10

 call CharOut , "Waiting for a key "
 parse value GetKey( thisDefault, thisTimeOut, "." ) with ,
             thisRC "," pressedKey "," KeyPressed "," isFunctionKey

 if thisRC = 1 then
   if keyPressed = 1 then
     if isFunctionKey = 1 then
       say "Pressed the function key with the code " || C2D( pressedKey )
     else
       say "Pressed key is <" || pressedKey || ">"
   else
     say "No key pressed. Using the default."
 else
   say "Error while calling GetKey()!"
exit 0

/* ------------------------------------------------------------------ */
/* function: Get a key with timeout                                   */
/*                                                                    */
/* usage:    GetKey default , timeOut, inProgressInd                  */
/*                                                                    */
/* where:    default       - default key                              */
/*           timeOut       - timeOut in seconds                       */
/*           inProgressInd - if <> "" char for the in progress        */
/*                           indicator                                */
/*                                                                    */
/* returns:  thisRc, key, keypressed, functionKey                     */
/*                                                                    */
/* where:    thisRC      - 1 if okay, else error                      */
/*           key         - pressed key (or default)                   */
/*           keypressed  - 1 if a key was pressed else 0              */
/*           functionKey - 1 if a function key was pressed else 0     */
/*                                                                    */
/* note:     This function does not work as desired in OO REXX! v2.30 */
/*           The reason is the different behaviour of the       v2.30 */
/*           function CHARS() in OO REXX!                       v2.30 */
/*                                                                    */
/*           [Tested with OBJREXX 6.00 12 Jul 1996]                   */
/*           [Fixed in OBJREXX 6.00 26 Feb 1997 and newer versions]   */
/*                                                                    */
GetKey: PROCEDURE
  parse arg default, timeOut, inProgressInd

                            /* init the return code(s)                */
  thisRC = 0
  thisKey = default
  keyPressed = 0
  functionKey = 0

                            /* install a local error handler          */
  SIGNAL ON SYNTAX Name GetKeyEnd

  do timeCount = 0 to timeOut
    if InProgressInd <> "" then
      call CharOut , inProgressInd

    if chars() <> 0 then
    do
                            /* there is a key available               */
      thisKey = SysGetKey( "NOECHO" )
      if thisKey = "00"x | thisKey = "E0"x then
      do
                            /* function key pressed                   */
        thisKey = SysGetKey( "NOECHO" )
        functionKey = 1
      end /* if thisKey = "00"x | thisKey = "E0"x then */
      keypressed = 1
      leave
    end /* if chars() <> 0 then */
    else
    do
                            /* wait a second                          */
      call SysSleep 1
    end /* else */
  end /* do timeCount = 0 to timeOut */

                            /* set rc to execution is okay            */
  thisRC = 1

  if inProgressInd <> "" then
    say ""

GetKeyEnd:
RETURN thisRC || "," || thisKey || "," || keyPressed || "," || FunctionKey
</PRE>

===sprintf routine for REXX===
This is an implementation of the C function sprintf in REXX from Bernie Schneider.
Captured from a message in a public Internet news group.
<PRE>
/* ------------------------------------------------------------------ */
/* Program: SPRINTF                                                   */
/* Purpose: Returns a string formatted according to the format string */
/*          specified in the first argument and the values specified  */
/*          in the remaining arguments. It is modeled after the       */
/*          SPRINTF function in the C/C++, AWK, PERL, etc.            */
/*          programming languages.                                    */
/*                                                                    */
/* Usage:   say sprintf(fmt_string, value1, value2, ..., valuen)      */
/*                                                                    */
/*  where fmt_string specifies the formatting to be done on the       */
/*  remaining arguments. The string is composed of literals and       */
/*  format specifiers. There should be one format specifier for       */
/*  each value to be formatted.                                       */
/*  Literals are considered to be anything that isn't a format        */
/*  specifier. Format specifiers are coded as follows:                */
/*                                                                    */
/*    %[-][w][.d]z                                                    */
/*                                                                    */
/*  where                                                             */
/*    "%" indicates the start of a format specifier. To use a %       */
/*        in a literal, specify two concecutive %s (%%, no argument   */
/*        value will be consumed).                                    */
/*    "-" is optional, and indicates that the argument value is to be */
/*        left justified in its field. If it isn't present, the value */
/*        will be right justified.                                    */
/*    "w" is optional, and it specifies the width of the field in     */
/*        characters. If it isn't specified, then as many characters  */
/*        as necessary will be used. For decimal numbers, this will   */
/*        depend on the current value of the numeric digits setting.  */
/*        The value will be truncated or padded with blanks as        */
/*        necessary to fit the width specified. Numbers to the right  */
/*        of the decimal point are padded with "0"s, and will be      */
/*        rounded if truncation is necessary. If a numeric value      */
/*        is -1 < valuen < +1, it will be padded with leading "0"s.   */
/*   ".d" is optional, and it specifies the maximum string width, or  */
/*        the number of digits to the right of the decimal point.     */
/*    "z" is a single character that indicates the type of conversion */
/*        to be performed on the corresponding argument value. It may */
/*        be one of the following:                                    */
/*          "d", formats a signed decimal integer                     */
/*          "f", formats a signed decimal real number                 */
/*          "s", formats a character string                           */
/*          "x", formats an unsigned hexadecimal number               */
/*                                                                    */
/*        Examples:                                                   */
/*          say sprintf("Number = %d", 25)                            */
/*            -> "Number = 25"                                        */
/*          say sprintf("Number = %5d", 25)                           */
/*            -> "Number =    25"                                     */
/*          say sprintf("String = %s", "March")                       */
/*            -> "String = March"                                     */
/*          say sprintf("String = %5.3s", "March")                    */
/*            -> "String =   Mar"                                     */
/*          say sprintf("Num = %8.2f", -123.456)                      */
/*            ->  "Num =  -123.46"                                    */
/*          say sprintf("Num = '%-4x'  String = '%-10s'", ,           */
/*                255, ,                                              */
/*                "AbCde")                                            */
/*            -> "Num = 'FF  '  String = 'AbCde     '"                */
/*          say sprintf("%5.1f%%", .1757 * 100)                       */
/*            -> " 17.6%"                                             */
/*          say sprintf("Num = %7.3f", 0.25)                          */
/*            -> "Num = 000.250"                                      */
/*                                                                    */
/* Written: 27Nov95                                                   */
/* Language:REXX                                                      */
/* Author:  Bernie Schneider                                          */
/* Notes:                                                             */
/* Revised:                                                           */
/*====================================================================*/
/*                                                                    */
sprintf: procedure
  argno = 1                     /* Initialize argument counter        */
  string = ""
  start = 1                     /* Initialize pointer                 */
  len = length(arg(1))

  do until(p >= len)
    s = ""
    argno = argno + 1
    p = pos("%", arg(1), start)
    if p = 0 then
    do
      p = len + 1
    end
    if substr(arg(1), p, 1) == "%" then
    do
      s = "%"
    end
    string = string || substr(arg(1), start, p - start)
    start = p + 1
    p = verify(arg(1), "%cdfsx", "M", start)
    if p = 0 then
      leave
    spec = substr(arg(1), start, p - start + 1)
    start = p + 1
    r = right(spec, 1)
    spec = delstr(spec, length(spec), 1)
    if left(spec,1) == "-" then
    do                          /* Get any additional specs           */
      left = 1
      spec = substr(spec, 2)
    end
    else
    do
      left = 0
      spec = substr(spec, 1)
    end
    if spec \== "" then                 /* Get width and precision    */
      parse var spec width "." prec
    else
    do
      width = 0
      prec = 0
    end
    if \datatype(width, "W") then
      width = 0
    if \datatype(prec, "W") then
      prec = 0
    pad = " "

    select

      when r == "s" then
      do
        if width = 0 then
          width = length(arg(argno))
        if prec \= 0 then
          s = left(arg(argno), prec)     /* Truncate or pad           */
        else
          s = arg(argno)
      end

      when r == "d" then
      do
        if width = 0 then
          width = length(arg(argno))
        s = format(arg(argno), length(arg(argno)), 0)
      end

      when r == "f" then
      do
        if arg(argno) > -1 & arg(argno) < 1 then
          pad = "0"
        parse value arg(argno) with int "." frac
        if width = 0 & prec = 0 then
        do
          d = 1
          if arg(argno) < 0 then d = 2
          width = digits() + d
          prec = digits() - (length(int)) + d - 1
        end
        if width = 0 then
          width = len - prec
        s = format(arg(argno), width, prec)
      end

      when r == "x" then
      do
        if width = 0 then
          width = length(arg(argno))
        s = d2x(arg(argno))
        if prec \= 0 then
          s = left(s, prec)     /* Truncate or pad                    */
      end

      when r == "%" then
      do
        argno = argno - 1
      end

      otherwise
        nop

    end /* select */

    if r \== "%" then
    do
      if left then
        s = left(strip(s), width, pad)      /* Justify                */
      else
        s = right(strip(s), width, pad)
    end
    string = string || s
  end /* do until(p >= len) */
return string
</PRE>

==Disk-, Directory- and File-Handling==
===Get the current boot drive===
<PRE>
/* ------------------------------------------------------------------ */
/* function: get the OS/2 boot drive                                  */
/*                                                                    */
/* call:     bootDrive = GetOS2BootDrive()                            */
/*                                                                    */
/* where:    -                                                        */
/*                                                                    */
/* returns:  the OS/2 boot drive                                      */
/*                                                                    */
/* note:                                                              */
/*                                                                    */
/* Note that there are functions to get the boot drive in many        */
/* REXX DLLs available, for example in the RXLANUTIL DLL or in the    */
/* new REXXUTIL DLL. introduced with Object-Oriented REXX             */
/*                                                                    */
GetOS2BootDrive: PROCEDURE expose (exposeList)

                    /* load the REXXUTIL functions                    */
  call rxFuncAdd "SysLoadFuncs", "REXXUTIL", "SysLoadFuncs"
  call SysLoadFuncs

                    /* install a local error handler                  */
  signal on Syntax name GetOS2BootDrive1

  boot_drive = ''
  boot_drive = SysBootDrive()

GetOS2BootDrive1:
                    /* if SysBootDrive() failed, boot_drive is still  */
                    /* empty                                          */
                    /* SysBootDrive() is only in the newer versions   */
                    /* of REXXUTIL!                                   */
  if boot_drive = '' then
  do
                    /* You should do further tests to ensure that     */
                    /* the result of this method is correct!          */
    parse upper value VALUE( "PATH",, prog.__env ) with "\OS2\SYSTEM" -2,
                        boot_drive +2
  end /* if boot_drive = '' then */

return boot_drive
</PRE>

===Check if a drive is ready===
<pre>
/* sample code to test if a drive is ready                            */
/* note:     This routine does not work under Object-Oriented REXX    */
/*                                                                    */
/*           [Tested with OBJREXX 6.00 12 Jul 1996]                   */
/*           [Fixed in OBJREXX 6.00 26 Feb 1997 and newer versions]   */
/*                                                                    */

  do forever
    call lineOut , "Enter the name of the drive to test " ,
                   "(RETURN to end): "
    thisDrive = strip( lineIn() )
    if thisDrive = "" then
      leave

    if DriveReady( thisDrive ) = 1 then
      say "The drive <" || thisDrive || "> is ready."
    else
      say "The drive <" || thisDrive || "> is not ready."
  end /* do forever */

exit 0

/* ------------------------------------------------------------------ */
/* function: Check if a drive is ready                                */
/*                                                                    */
/* call:     DriveReady( testDrive )                                  */
/*                                                                    */
/* where:    testdrive - Name of the drive to test (e.g. "A:")        */
/*                                                                    */
/* returns:  1 - drive is ready                                       */
/*           0 - drive is not ready                                   */
/*                                                                    */
/* note:     This routine does not work under Object-Oriented REXX    */
/*           if the line AUTOFAIL=NO is missing in the CONFIG.SYS     */
/*                                                                    */
/*           [Tested with OBJREXX 6.00 12 Jul 1996]                   */
/*           [Fixed in OBJREXX 6.00 26 Feb 1997 and newer versions]   */
/*                                                                    */
DriveReady: PROCEDURE
  parse arg driveToTest ":" .

  thisRC = 0

                        /* install a temporary error handler to check */
                        /* if the drive is ready                      */
  SIGNAL ON NOTREADY Name DriveReadyEnd

  call stream driveToTest || ":\*", "D"
  thisRC = 1

DriveReadyEnd:
  RETURN thisRC
</PRE>

===Check if a directory exists===
<PRE>
/* sample code to test if a directory exists with restoring all       */
/* directories                                                        */

  do forever
    call lineOut , "Enter the name of the directory to test " ,
                   "(RETURN to end): "
    thisDir = strip( lineIn() )
    if thisDir = "" then
      leave

    if DirExist( thisDir ) <> "" then
      say "The directory <" || thisDir || "> exist."
    else
      say "The directory <" || thisDir || "> does not exist."
  end /* do forever */

exit 0

/* ------------------------------------------------------------------ */
/* function: Check if a directory exists                              */
/*                                                                    */
/* call:     DirExist( testDir )                                      */
/*                                                                    */
/* where:    testDir - name of the directory to test                  */
/*                                                                    */
/* returns:  full name of the directory or "" if the directory        */
/*           don't exist                                              */
/*                                                                    */
DirExist: PROCEDURE
  parse arg testDir .

                        /* init the return code                       */
  thisRC = ""

                        /* test for missing or invalid parameter      */
  testDir = strip( testDir )                                 /* v3.20 */
  if testDir = "" then                                       /* v3.20 */
    signal DirDoesNotExist                                   /* v3.20 */

  if right( testDir, 1 ) = '\' then                          /* v3.20 */
    testDir = dbrright( testDir,1 )                          /* v3.20 */
  testDir = testDir || '\.'                                  /* v3.20 */

                        /* install a temporary error handler to check */
                        /* if the drive with the directory to test is */
                        /* ready                                      */
  SIGNAL ON NOTREADY NAME DirDoesNotExist

                        /* check if the drive is ready                */
  call stream testDir || "\*", "D"


                        /* save the current directory of the current  */
                        /* drive                                      */
  curDir = directory()

                        /* save the current directory of the drive    */
                        /* with the directory to test                 */
  curDir1 = directory( fileSpec( "drive", testDir ) )


                        /* test if the directory exists               */
  thisRC = directory( testDir )

                        /* restore the current directory of the drive */
                        /* with the directory to test                 */
  call directory curDir1

                        /* restore the current directory of the       */
                        /* current drive                              */
  call directory curDir
DirDoesNotExist:

return thisRC
</PRE>

===Work on directory trees===
<PRE>
/* example for working on a directory tree without loading the dll    */
/* REXXUTIL                                                           */

                        /* flush the REXX queue                 v3.20 */
  do while queued() <> 0; parse pull; end;

                        /* put a list of all directories in the queue */
                        /* (use /FIFO to get the directories in the   */
                        /*  right order)                              */
  "@dir /s/f /Ad C:\ 2>NUL | RXQUEUE /FIFO"

  foundDirs.0 = 0
                    /* put the names of all found directories         */
                    /* in a compound variable for further processing  */
  do while queued() <> 0
    curDir = strip( lineIn( "QUEUE:" ) )
    if curDir <> "" & ,
       right( CurDir, 2 ) <> "\."  & ,
       right( CurDir, 3 ) <> "\.." then
    do
      j = foundDirs.0 + 1
      foundDirs.j = curDir
      foundDirs.0 = j
    end /* if curDir <> "" then */
  end /* do while queued <> 0 */
</PRE>

===Create a directory(-tree)===
<PRE>
/* ------------------------------------------------------------------ */
/* function: Create a directory(tree)                                 */
/*                                                                    */
/* call:     CreateDirectory dirToCreate                              */
/*                                                                    */
/* where:    dirToCreate - directory to create                        */
/*                                                                    */
/* example:  call dirToCreate C:\TEST1\TEST2\TEST3\TEST4              */
/*           will create the directories                              */
/*             C:\TEST1                                               */
/*             C:\TEST1\TEST2                                         */
/*             C:\TEST1\TEST2\TEST3                                   */
/*           and                                                      */
/*             C:\TEST1\TEST2\TEST3\TEST4                             */
/*                                                                    */
/* returns:  0 - okay                                                 */
/*           else OS Error                                            */
/*                                                                    */
CreateDirectory: PROCEDURE
  parse arg dirToCreate

                        /* file or device for messages                */
  prog.__LogAll = "2>NUL 1>NUL"

                        /* init the return code                       */
  thisRC = -1
                        /* check if the drive is ready                */
  SIGNAL ON NOTREADY Name CreateDirectoryError
  call stream fileSpec( "drive", dirToCreate ) || "\*"

  thisRC = 0
                        /* save the current directories               */
  curDir = directory()
  curDir1 = directory( fileSpec( "drive", dirToCreate ) )

  newDir = translate( dirToCreate, "\", "/" )

  i = pos( ":", dirToCreate )
  if i <> 0 then
  do
    parse var dirToCreate lwForTheDir ":" dirToCreate
    if directory( lwForTheDir || ":\" ) = "" then
      thisRC = 1
  end /* if i <> 0 then */

  if thisRC = 0 then
  do
    if right( dirToCreate, 1 ) <> "\" then
      dirToCreate = dirToCreate || "\"

    do until dirToCreate = "" | thisRC <> 0
      parse var dirToCreate newSubDir "\" dirToCreate
      dirToCreate = strip( dirToCreate )

      if newSubDir = '' then                                 /* v3.20 */
        iterate                                              /* v3.20 */

      if directory( newSubDir ) = "" then
      do
        '@md "' || newSubDir || '"' prog.__LogAll            /* v3.00 */
        if rc = 2 | rc = 1 then
        do
          if stream( newSubDir , "c", "QUERY EXISTS" ) <> "" then
            thisRC = rc
        end /* if rc = 2 | rc = 1 */
        else
          thisRC = rc

        if thisRC = 0 then
          call directory newSubDir
      end /* if directory( newSubDir ) = "" then */
    end /* do until dirToCreate = "" | thisRC <> 0 */
  end /* if thisRC = 0 then */

                        /* restore the current directories            */
  call directory curDir1
  call directory curDir

CreateDirectoryError:

RETURN thisRC
</PRE>

===Delete a directory(-tree)===
<PRE>
/* ------------------------------------------------------------------ */
/* function: Delete all files in a directory and in all its           */
/*           sub directories!                                         */
/*                                                                    */
/* call:     DeleteDirectory dirToDelete                              */
/*                                                                    */
/* where:    dirToDelete - directory to delete                        */
/*                                                                    */
/* returns:  0 - okay                                                 */
/*          -1 - drive not ready                                      */
/*          -2 - missing or invalid parameter                   v3.10 */
/*                                                                    */
/* note:     see also The function SysDestroyObject                   */
/*                                                                    */
DeleteDirectory: PROCEDURE
  parse arg dirToDelete

  signal off error                                           /* v3.20 */
  signal off notready                                        /* v3.20 */
  signal off failure                                         /* v3.20 */

  if dirToDelete = '' then                                   /* v3.10 */
  do                                                         /* v3.10 */
                        /* check for missing parameter          v3.10 */
    thisRC = -2                                              /* v3.10 */
    signal DeleteDirectoryError                              /* v3.10 */
  end /* if */

                        /* file or device for messages                */
  prog.__LogAll = "2>NUL 1>NUL"

                        /* init the return code                       */
  thisRC = -1
                        /* check if the drive is ready                */
  SIGNAL ON NOTREADY Name DeleteDirectoryError
  call stream fileSpec( "drive", dirToDelete ) || "\*"

                        /* flush the REXX queue                 v3.20 */
  do while queued() <> 0; parse pull; end;

                        /* put a list of all subdirectories in the    */
                        /* queue                                      */
  "@dir /s/f /Ad " dirToDelete "2>NUL | RXQUEUE /lifo "

  do while queued() <> 0
    dirToDel = lineIn( "QUEUE:" )
    if dirTodel <> "" & right( dirToDel,2 ) <> "\." & ,
       right( dirToDel,3 )  <> "\.." then
    do
                    /* also delete hidden, system and read-only files */
                                                             /* v3.20 */
      '@attrib -r -s -h "' || dirToDel || '\*.*"' "2>NUL 1>NUL"

                                                             /* v3.20 */
      if stream( dirToDel || '\*.*', 'c', 'QUERY EXISTS' ) <> '' then
        '@del /n "' || dirToDel || '\*.*"' prog.__LogAll     /* v3.00 */

      if dirToDel <> dirToDelete then
        '@rd  "' || dirToDel || '"' prog.__LogAll            /* v3.00 */
    end /* if dirToDel <> "" then */
  end /* do while queued <> 0 */

                    /* also delete hidden, system and read-only files */
                                                             /* v3.20 */
  '@attrib -r -s -h "' || dirToDelete || '\*.*"' "2>NUL 1>NUL"

                                                             /* v3.20 */
  if stream( dirToDelete || '\*.*', 'c', 'QUERY EXISTS' ) <> '' then
    '@del /n "' || dirToDelete || '\*.*"' prog.__LogAll

  '@rd "' || dirToDelete || '"' prog.__logAll                /* v3.00 */

  thisRC = 0

DeleteDirectoryError:

RETURN thisRC
</PRE>

===Check if a name describes a device or a file===
<pre>
/* check if a name is the name of a file or the name of a device      */
/*                                                                    */
/* note:                                                        v2.40 */
/*                                                                    */
/*  Another method to test if a name is a device name or filename is  */
/*                                                                    */
/*   testName = stream( testFileName, "c", "QUERY EXISTS" )           */
/*   if fileSpec( "P", testName ) = "\DEV\" then                      */
/*      say testFileName || " is a device."                           */
/*   else                                                             */
/*      say testFileName || " can be a file or directory."            */
/*                                                                    */

  if stream( testFileName, "c", "QUERY EXISTS" ) <> "" then  /* v2.00 */
    if stream( testFileName, "c", "QUERY DATETIME" ) = "" then
      say TestFileName || " is a device!"
    else
      say TestFileName || " is a file!"
  else                                                       /* v2.00 */
    say TestFileName || " does not exist!"                   /* v2.00 */
</PRE>

===Check if a file exist===
<PRE> 
/* example code to check if a file exists. This function also checks, */
/* if the name is already used by a directory or a device (e.g. CON)  */
/* Note that this routine won't find hidden or system files.          */

  do until fileName = ""
    call charOut, "Enter a filename to check: "
    fileName = lineIN()
    say "The result of FileExist(" || fileName || ") is: " || ,
        FileExist( fileName )                                /* v2.60 */
  end /* do until iLIne = "" */

exit 0

/* ------------------------------------------------------------------ */
/* function: Check if a file exists                                   */
/*                                                                    */
/* call:     FileExist fileToTest                                     */
/*                                                                    */
/* where:    fileToTest - name of the file to test                    */
/*                                                                    */
/* returns:  -2 - invalid parameter                                   */
/*           -1 - cannot detect (e.g. the drive is not ready)         */
/*            0 - neither a file, a device nor a directory with this  */
/*                name exist                                          */
/*            1 - the file exist                                      */
/*            2 - a device driver with the name exists                */
/*            3 - a directory with the name exists                    */
/*                                                                    */
FileExist: PROCEDURE
  parse arg fileName                                         /* v2.90 */

                        /* install temporary error handler            */
  SIGNAL ON NOTREADY NAME FileExistError
  SIGNAL ON FAILURE  NAME FileExistError
  SIGNAL ON ERROR    NAME FileExistError

  thisRC = -2           /* rc = -2 ->> invalid parameter              */

                        /* check the parameter                        */
  if strip( fileName ) <> "" then
  do
    thisRC = -1         /* rc = -1 ->> cannot detect the result       */

                        /* check if the drive with the file is ready  */
    call stream fileName
                        /* turn of some error handling so we can      */
                        /* determine if the given name is the name of */
                        /* a device (for example "LPT1")              */
    SIGNAL OFF NOTREADY

    if stream( fileName, "c", "QUERY EXISTS" ) <> "" then
    do
                        /* seems that the file exists -- check if     */
                        /* it is a device                             */
      if stream( fileName, "c", "QUERY DATETIME" ) == "" then
        thisRC = 2      /* rc = 2 ->> this is a device name           */
      else
        thisRC = 1      /* rc = 1 ->> this is a file name             */
    end /* if stream( ... */
    else
    do
                        /* seems that the file does not exist --      */
                        /* check if a directory with the name for the */
                        /* file exist                                 */

                        /* save the current directory of the current  */
                        /* drive                                      */
      thisDir = directory()
                        /* save the current directory of the drive    */
                        /* with the file to check                     */
      tempDir = directory( fileSpec( "Drive", fileName ) )

      if directory( fileName ) <> "" then
        thisRC = 3      /* rc = 3 ->> a dir with this name exists     */
      else
        thisRC = 0      /* rc = 0 ->> neither a file, a device nor a  */
                        /*            dir with this name exists       */

                        /* restore the current directory of the drive */
                        /* with the directory to check                */
      call directory tempDir
                        /* restore the current directory of the       */
                        /* current drive                              */
      call directory thisDir
    end /* else */
  end /* if strip( fileName ) <> "" then */

FileExistError:

RETURN thisRC
</PRE>

===Get a name for a temporary file===
<PRE>
/* routine to get an unique name for a temporary file                 */

                        /* example call                               */
  tempFile = GetTempFile()
  if tempFile <> "" then
    say "The name of the temporary file is " || tempFile
  else
    say "Error: Cannot find a name for a temporary file!"

                        /* close & delete the temporary file          */
  if tempFile <> "" then
  do
    call stream tempFile, "C", "CLOSE"
    '@del "' || tempFile || '"2>NUL 1>NUL'
  end /* if tempFile <> "" then */

exit 0

/* ------------------------------------------------------------------ */
/* function: Get an unique name for a temporary file                  */
/*                                                                    */
/* call:     GetTempFile {noOfTrys} {,targetDir}                      */
/*                                                                    */
/* where:    noOfTrys - no. of trys                                   */
/*                      (optional, def.: 999)                         */
/*           targetDir - target dir for the file                      */
/*                       The directory must exist                     */
/*                       (optional, def.: use the environment         */
/*                       variable TEMP, the environment variable      */
/*                       TMP or the current directory [in this order])*/
/*                                                                    */
/* returns:  name of the file                                         */
/*           or "" if no name was found                               */
/*                                                                    */
/* note:     If GetTempFile finds a name for a new temporary file,    */
/*           it opens this file to prevent it from being used by      */
/*           another process!                                         */
/*           The name of the file is in the format $$nnn$$.TMP where  */
/*           nnn is a number between 000 and 999.                     */
/*                                                                    */
/*           RXTT v2.90: Added parameter noOfTrys and tPath           */
/*                                                                    */
GetTempFile: PROCEDURE expose (exposeList)
  parse arg noOfTrys, tPath                                  /* v2.90 */

  if noOfTrys = '' | datatype( noOfTrys ) <> 'NUM' then      /* v2.90 */
    noOfTrys = 999                                           /* v2.90 */

  if tPath = '' then                                         /* v2.90 */
  do
                        /* get the path for the temporary file        */
    tPath = value( "TEMP", , prog.__Env )
    if tPath = "" then
      tPath = value( "TMP", , prog.__Env )
    if tPath = "" then
      tPath = directory()

    tPath = translate( tPath )                               /* v2.20 */
  end /* if */

  tName = ""
                        /* save the current drive and directory       */
  CurDir = directory()

                        /* get the drive with the directory for the   */
                        /* temporary files                            */
  CurTDrive = filespec( "Drive", tPath )

                        /* save the current directory of the drive    */
                        /* with the directory for temporary files!    */
  CurTDir = directory( curTDrive )

  if directory( tPath ) = tPath then
  do

                        /* restore the current directory of the drive */
                        /* with the directory for temporary files!    */
    call directory CurTDir
                        /* restore the current drive and directory    */
    call directory CurDir

    tPath = strip( tPath, "B", '"' )
    if right( tPath, 1 ) <> "\" then
      tPath = tPath || "\"

    do i=0 to noOfTrys
      tName = tPath || "$$" || right( "000" || i, 3 ) || "$$" || ".TMP"
      if stream( tName, "C", "QUERY EXISTS" ) = "" then
        if stream( tName, "C",,
                   "OPEN WRITE" ) = "READY:" then            /* v2.20 */
          leave i

      tName = ""
    end /* do i=1 to noOfTrys */
  end /* if directory() = ... */

RETURN tName
</PRE>

===Search a file===
<PRE>
/* routine(s) to search a file in the directories saved in an         */
/* environment variable (e.g. "PATH")                                 */
/* Note that this routine won't find hidden or system files.          */

                        /* example call                               */
  do forever
    say "Enter a filename ("""" to abort):"
    searchFile = strip( lineIn() )

    if searchFile = '' then
      leave

    say "Result of SearchDataFile(" || searchFile || ") is: "
    say "  """ || SearchDataFile( searchFile ) || """"
    say "Result of SearchProgram(" || searchFile || ") is: "
    say "  """ || SearchProgram( searchFile ) || """"
  end /* do forever */

exit 0

/* ------------------------------------------------------------------ */
/* function: Search a file in the current directory and in the        */
/*           directories saved in an environment variable             */
/*           (e.g. PATH, DPATH, ... )                                 */
/*                                                                    */
/* call:     SearchFile( fileName, varName {,environment})            */
/*                                                                    */
/* where:    fileName - name of the file to search                    */
/*           varName - name of the environment variable containing    */
/*                     the directories to search                      */
/*           environment - environment with the environment Variable  */
/*                         (Def.: OS2ENVIRONMENT)                     */
/*                                                                    */
/* returns:  full name of the file or "" if not found                 */
/*                                                                    */
SearchFile: PROCEDURE
  parse arg fileName , envVar, environment
  resultStr = ""

  if fileName <> "" & envVar <> "" then
  do
    if environment = '' then
      environment = "OS2ENVIRONMENT"

    searchDirs = ".;" || value( envVar, , environment )

    do forever
      parse var searchDirs curSearchDir ";" searchDirs

      curSearchDir = strip( curSearchDir )

      if curSearchDir = "" then
        iterate

      if right( curSearchDir, 1 ) <> "\" & ,
         right( curSearchDir, 1 ) <> ":" then
        curSearchDir = curSearchDir || "\"

      resultStr = stream( curSearchDir || fileName, "c", "QUERY EXISTS" )
      if resultStr <> "" then
        leave

      if SearchDirs = "" then
        leave

    end /* do forverver */
  end /* if fileName <> "" & ... */

RETURN resultStr

/* ------------------------------------------------------------------ */
/* function: Search a file in the current directory and in the        */
/*           directories saved in the environment variable PATH       */
/*                                                                    */
/* call:     SearchProgram( progName {,environment})                  */
/*                                                                    */
/* where:    progName - name of the program to search                 */
/*           environment - environment with the environment Variable  */
/*                         (Def.: OS2ENVIRONMENT)                     */
/*                                                                    */
/* returns:  full name of the program or "" if not found              */
/*                                                                    */
SearchProgram: PROCEDURE
  parse arg progName , environment
  resultStr = ""
  if progName <> "" then
    resultStr = SearchFile( progName, "PATH", environment )
RETURN resultStr

/* ------------------------------------------------------------------ */
/* function: Search a datafile in the current directory and in the    */
/*           directories saved in the environment variable DPATH      */
/*                                                                    */
/* call:     SearchProgram( datafileName {,environment})              */
/*                                                                    */
/* where:    datafileName - name of the datafile to search            */
/*           environment - environment with the environment Variable  */
/*                         (Def.: OS2ENVIRONMENT)                     */
/*                                                                    */
/* returns:  full name of the datafile or "" if not found             */
/*                                                                    */
SearchDataFile: PROCEDURE
  parse arg dataFileName , environment
  resultStr = ""
  if dataFileName <> "" then
    resultStr = SearchFile( datafileName, "DPATH", environment )
RETURN resultStr
</PRE>

===Count lines in a file quickly===
<PRE>
/* sample code to count the lines in a file quickly                   */
/*                                                                    */
/* Source: I found this code in a message on the internet             */
/*                                                                    */
/* see also Count lines in a file quickly - 2 -                       */
/*                                                                    */

                        /* name of the file                           */
  testFile = "C:\OS2\INISYS.RC"

  call time "r"

  noOfLines = CountLines( testFile )

  if noOfLines >= 0 then
  do
    say "The file " || testFile || " contains " || ,
        noOfLines || " lines."
    say "It took " || time( "e" ) || " seconds to get the number."

  end /* if */
  else
    say "Error reading the file " || testFile

exit 0

/* ------------------------------------------------------------------ */
/* function: Get the number of lines in a file                        */
/*                                                                    */
/* call:     CountLines( fileName )                                   */
/*                                                                    */
/* where:    fileName - name of the file                              */
/*                                                                    */
/* returns:  n                                                        */
/*             if n is >= 0 then it is the number of lines            */
/*             if n is < 0 an error occurred                          */
/*                                                                    */
CountLines: PROCEDURE
  parse arg fileName

  if stream( fileName, "c", "QUERY EXISTS" ) <> "" then
  do
    if stream( fileName, "c", "OPEN READ" )  = "READY:" then
    do

      thisRC = 0
      do while chars( fileName ) > 0

        thisRC = thisRC + ,
         words( translate( charin( fileName, , 24020 ), "          1" ) )

      end /* do while chars( fileName ) > 0 */
      call stream fileName, "c", "close"

    end /* if stream( fileName, "c", "open read" )  = "READY:" then */
    else
      thisRC = -1

  end /* if stream( fileName, "c", "QUERY EXISTS" ) <> "" then */
  else
    thisRC = -2

RETURN thisRC
</PRE>

===Count lines in a file quickly - 2 -===
<PRE>
/* another sample code to count the lines in a file quickly           */
/*                                                                    */
/* Source: Oliver Heidelbach (see EMail Addresses)                    */
/*                                                                    */
/* see also Count lines in a file quickly                             */
/*                                                                    */

                        /* name of the file                           */
  testFile = "C:\OS2\INISYS.RC"

  call time "r"

  noOfLines = CountLines( testFile )

  if noOfLines >= 0 then
  do
    say "The file " || testFile || " contains " || ,
        noOfLines || " lines."
    say "It took " || time( "e" ) || " seconds to get the number."

  end /* if */
  else
    say "Error reading the file " || testFile

exit 0

/* ------------------------------------------------------------------ */
/* function: Get the number of lines in a file                        */
/*                                                                    */
/* call:     CountLines( fileName )                                   */
/*                                                                    */
/* where:    fileName - name of the file                              */
/*                                                                    */
/* returns:  n                                                        */
/*             if n is >= 0 then it is the number of lines            */
/*             if n is < 0 an error occurred                          */
/*                                                                    */
CountLines: PROCEDURE
  parse arg fileName

  if stream( fileName, "c", "QUERY EXISTS" ) <> "" then
  do
    if stream( fileName, "c", "OPEN READ" )  = "READY:" then
    do

      thisRC = 0

      buf = charin( File,1,stream( filename,'c','query size' ) )
      call stream filename, 'c', 'close'

      buf = translate( buf,copies( ' ',10 ) || '1' || copies( ' ',245 ) )
      buf = space( buf,0 )
      thisRC = length( buf )

    end /* if stream( fileName, "c", "open read" )  = "READY:" then */
    else
      thisRC = -1

  end /* if stream( fileName, "c", "QUERY EXISTS" ) <> "" then */
  else
    thisRC = -2

RETURN thisRC
</PRE>

===Read a file into a compound variable===
<PRE>
/* sample code to read a text file into a compound variable           */

                        /* name of the file to read                   */
  testFile = "C:\OS2\INISYS.RC"

  if ReadTextFile( testFile  , "testStem" ) = 0 then
  do
    say "The file " || testFile || " contains " || ,
        testStem.0 || " lines."
  end /* if */
  else
    say "Error reading the file " || testFile

exit 0

/* ------------------------------------------------------------------ */
/* function: Read a text file into a compound variable                */
/*                                                                    */
/* call:     ReadTextFile fileName, stem                              */
/*                                                                    */
/* where:    fileName - name of the file to read                      */
/*           stem - stem for the lines of the file                    */
/*                                                                    */
/* returns:  0 - okay, file read, the compound variable "stem"        */
/*                     contains the lines of the file,                */
/*                     "stem".0 = no. of lines                        */
/*           else error reading the file                              */
/*                                                                    */
ReadTextFile:
  parse arg rtf.__fileName , rtf.__stemName

                        /* set the return code                        */
  rc = -1

  rtf.__i = i

  if rtf.__fileName <> "" & rtf.__stemName <> "" then
  do
    if right( rtf.__stemName,1 ) <> "." then
      rtf.__StemName = rtf.__StemName || "."

                        /* init the number of stem elements with 0    */
    rtf.__iLine = rtf.__StemName || "0 = 0 "
    interpret rtf.__iLine

                        /* set the return code 2 - file not found     */
    rc = 2

    if stream( rtf.__fileName, "c", "QUERY EXISTS" ) <> "" then
    do

                        /* set return code to 0                       */
      rc = 0

                        /* create the code to read the file           */
      rtf.__iLine = ,
       "do i = 1 until lines( """ || rtf.__fileName || """ ) = 0; "  ,
          rtf.__StemName || "i = lineIn( '" || rtf.__fileName || "');" ,
       "end;"
                        /* and now execute the code to read the file  */
      interpret rtf.__iLine

                        /* close the file                             */
      call stream rtf.__fileName, "c", "CLOSE"

                        /* correct the no. of lines in stem.0         */
      rtf.__iLine = rtf.__StemName || "0 = i "
      interpret rtf.__iLine

    end /* if stream( ... */

  end /* if rtf.__fileName <> "" & ... */

  i = rtf.__i
  drop rtf.

RETURN rc
</PRE>

===Write a stem using CharOut()===
<PRE>
/* ------------------------------------------------------------------ */
/* function: Write a stem into a file                                 */
/*                                                                    */
/* call:     rxWriteStem = stem_with_the_lines                        */
/*           call RxWriteTextFile fileName  {, lineSep } {,noEmpty}   */
/*                                                                    */
/* where:    rxWriteStem - name of the stem with the file contents    */
/*                        The name MUST end with a dot!               */
/*           fileName - name of the file to write                     */
/*           LineSep - line separator chars                           */
/*                     (def.: "0D0A"x)                                */
/*           noEmpty - if 1 empty lines are not written               */
/*                     (def.: 0)                                      */
/*                                                                    */
/* returns:                                                           */
/*           0 -> ok                                                  */
/*           1 -> parameter missing                                   */
/*           2 -> could not write the whole file                      */
/*           3 -> variable referenced in RxWriteStem is invalid       */
/*           4 -> NOTREADY condition occurred                         */
/*           5 -> ERROR condition occurred                            */
/*           6 -> FAILURE condition occurred                          */
/*           7 -> unexpected condition occurred                       */
/*                                                                    */
RxWriteTextFile: PROCEDURE expose (RxWriteStem) (exposeList)

                    /* install local error handlers                   */
  SIGNAL ON  NOTREADY Name RxWriteTextFileError
  SIGNAL ON  ERROR    Name RxWriteTextFileError
  SIGNAL ON  FAILURE  Name RxWriteTextFileError

                    /* init the return code                           */
  thisRC = 3
                    /* check the name of the variable for the         */
                    /* result                                         */
  if  symbol( rxWriteStem || 0 ) = 'VAR' & right( rxWriteStem,1 ) = '.' then
  do
                    /* get the parameter                              */
    parse arg fileName , lineSep, noEmpty

                    /* remove leading and trailing blanks from the    */
                    /* parameter                                      */
    fileName = strip( fileName )
    lineSep = strip( lineSep )

                    /* use default line separator if necessary        */
    if arg( 2, 'o' ) = 1 "" then
      lineSep = d2c(13) || d2c(10)

    if noEmpty = "" then
      noEmpty = 0

                    /* set the return code                            */
    thisRC = 1

    if fileName <> "" then
    do
                    /* copy the stem into a variable                  */
      fileContents = ''
      do i = 1 to value( RxWriteStem || 0 )
        curLine = value( RxWriteStem || i )
        if noEmpty = 1 & curLine = '' then
          iterate
        fileContents = fileContents || curLine || lineSep
      end /* do lineCount = 1 to value( RxWriteStem || 0 ) */

                    /* open the file                                  */
      call stream fileName, "c", "OPEN WRITE"
                    /* write the complete file using CharOut()        */
      tRC = CharOut( fileName, fileContents, 1 )
                    /* close the file                                 */
      call stream fileName, "c", "CLOSE"
      if tRC <> 0 | result <> 'READY:' then
        thisRC = 2
      else
        thisRC = 0

    end /* if filename <> "" then */
  end /* if */

RETURN thisRC

/* error exit for RxWriteTextFile                                     */

RxWriteTextFileError:
                    /* turn off the condition that caused the error   */
  INTERPRET 'SIGNAL OFF ' condition( 'C' )

  curCondition = condition('C')
  select
    when curCondition = 'NOTREADY' then
      thisRC = 4
    when curCondition = 'ERROR' then
      thisRC = 5
    when curCondition = 'FAILURE' then
      thisRC = 6
    otherwise
      thisRC = 7
  end /* select */

                    /* close the file                                 */
  call stream fileName, 'c', 'CLOSE'

return thisRC
</PRE>

===Expand the function FILESPEC===
<PRE>
/* sample code to extend the FILESPEC function with code to extract   */
/* the extension of a fileName                                        */

  do until myInput = ""
    say "New options for FILESPEC are:"                      /* v2.30 */
    say "-----------------------------"                      /* v2.30 */
    say "E - return the extension of the file"               /* v2.30 */
    say "B - return the name without the extension of the file"  /* " */
    say "H - return the drive & path of the file"            /* v2.30 */
    say "-----------------------------"                      /* v2.30 */
    say "Enter the parameter for FILESPEC(option, fileName): "
    myInput = strip( lineIn() )
    if myInput <> "" then
    do
      parse var myInput myOption "," myfileName
      say "The result of FILESPEC( " myOption "," myfileName ") is: "
      say "<" || fileSpec( myOption, myfileName ) || ">"
    end /* if myInput <> "" then */
  end /* do until myInput = "" */

exit 0

/* ------------------------------------------------------------------ */
/* function: Extended FILESPEC function                               */
/*                                                                    */
/* call:     FileSpec option,fileName                                 */
/*                                                                    */
/* where:    option                                                   */
/*                                                                    */
/*             - E{xtension}                                          */
/*               return the extension of the file                     */
/*                                                                    */
/*             - B{asename}                                           */
/*               returns the name of the file without extension       */
/*                                                                    */
/*             - H{ome]                                               */
/*               returns the fully qualified path of the file         */
/*               (including the drive specifier; without the trailing */
/*               backslash)                                           */
/*                                                                    */
/*             All other values for "option" are processed by the     */
/*             original FILESPEC function.                            */
/*                                                                    */
/*           fileName                                                 */
/*             - name of the file                                     */
/*                                                                    */
/* returns:  if option = E{xtension}:                                 */
/*             the extension of the fileName or "" if none            */
/*           else                                                     */
/*             if option = B{asename}:                                */
/*               the name of the file without the path and extension  */
/*             else                                                   */
/*               the return code of the original FILESPEC function    */
/*               or "SYNTAX ERROR" if called with invalid parameter   */
/*                                                                    */
/* note:     To call the original FILESPEC function directly, use     */
/*             myResult = "FILESPEC"( option, fileName )              */
/*                                                                    */
/* history:                                                           */
/*           RXT&T v1.90 /bs                                          */
/*            - added the option B{asename}                           */
/*           RXT&T v2.30 /bs                                          */
/*            - added the option H{ome}                               */
/*                                                                    */
FileSpec: PROCEDURE
  parse arg option, fileName

                        /* init the return code                       */
  rc = "SYNTAX ERROR"
                        /* install a local error handler              */

  SIGNAL ON SYNTAX NAME FileSpecError

  fileName = strip( fileName )                               /* v2.30 */
  option = translate( strip( option ) )

                        /* check the option code                      */
  select

    when abbrev( "EXTENSION", option ) = 1 then
    do
                        /* process the new added option code          */
      i = lastPos( ".", fileName )
      if i > lastPos( "\", fileName ) then
        rc = substr( fileName, i+1 )
      else
        rc = ""
    end /* when */

    when abbrev( "BASENAME", option ) = 1 then               /* v1.90 */
    do                                                       /* v1.90 */
                        /* call the original FILESPEC function  v1.90 */
                        /* to get the filename                  v1.90 */
      rc = "FILESPEC"( "N", fileName )                       /* v1.90 */
      i = lastpos( ".", rc )                                 /* v1.90 */
      if i <> 0 then                                         /* v1.90 */
        rc = substr( rc,1, i-1 )                             /* v1.90 */
    end /* when */                                           /* v1.90 */

    when abbrev( "HOME", option ) = 1 then                   /* v2.30 */
    do                                                       /* v2.30 */
      rc = "FILESPEC"( "D", fileName ) ||,                   /* v2.30 */
           "FILESPEC"( "P", fileName )                       /* v2.30 */
      if right( rc,1 ) = "\" then                            /* v2.30 */
        rc = dbrright( rc,1 )                                /* v2.30 */
    end /* when */                                           /* v2.30 */

    otherwise
    do
                        /* call the original FILESPEC function        */
      rc = "FILESPEC"( option, fileName )
    end /* otherwise */

  end /* select */

FileSpecError:

RETURN rc
</PRE>

===Maintain Multi-Value EAs in REXX===
<PRE>
/*                                                                    */
/* sample routine to maintain multi-Value EAs in REXX                 */
/* The Demo program uses the EA ".HISTORY"                            */
/*                                                                    */
/* (see also Extended Attribute Data Types and EAs used by the WPS)   */
/*                                                                    */
  say ""
  say "Sample program to show the use of the routine FileHistory"
  say ""

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

                    /* get the name of this file                      */
  parse source . . thisFile

                    /* load the REXXUTIL functions for the demo       */
  call rxFuncAdd "SysLoadFuncs", "REXXUTIL", "SysLoadFuncs"
  call SysLoadFuncs

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

  say "Now detecting the history of this file ..."
  call ReadEA1

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

  say "Now initializing the history of this file with 1 value ..."

  call FileHistory "ADD", thisFile,,
                   "Jim Bacon    Created    01.01.1995", testStem
  say "  Result of FileHistory is " || result

  call ReadEA

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

  say "Now initializing the history of this file with 3 values ..."

  MyStem1.0 = 3
  MyStem1.0.codepage = 0
  Mystem1.1 = "Jon Doe I     Created      20.01.1995"
  MyStem1.2 = "Jon Doe II    Changed      22.01.1995"
  MyStem1.3 = "Jon Doe III   Changed      23.01.1995"

  call FileHistory "SET", thisFile, "MyStem1"
  say "  Result of FileHistory is " || result

  call ReadEA
/* -------------------------- */

  say "Now adding another entry to the history of this file ..."
  call FileHistory "ADD", thisFile, "Jim Bean   Changed   24.01.1995"
  say "  Result of FileHistory is " || result

  call ReadEA

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

  say 'Now deleting the history of this file ...'
  call FileHistory 'CLEAR', thisFile
  say '  Result of FileHistory is ' || result

  call ReadEA

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

exit

/*                                                                    */
/* demo subroutine to read the EA                                     */
/*                                                                    */
ReadEA:
  say "Now reading the new history of this file ..."

ReadEA1:
  call FileHistory "GET", thisFile, "MyStem"
  say "  Result of FileHistory is " || result

  say "  The history list for this file contains " || ,
      MyStem.0 || " entries."
  say "  The codepage of the history list is " || MyStem.0.CodePage || "."

  do i = 1 to MyStem.0
    say "  History list entry no " || i  || " is  "
    say "     <" || myStem.i || ">"
  end /* do i = 1 to MyStem.0 */

  say "Press O to open the Settings Notebook of this file " || ,
      "or any other key to continue"
  UserInput = translate( SysGetKey( "NOECHO" ) )
  if userInput = "O" then
  do
    call SysOpenObject thisFile, 2 , 1
    say "Close the Settings Notebook and press any key to continue"
    UserInput = translate( SysGetKey( "NOECHO" ) )
  end /* if userInput = "O" then */
RETURN

/* ------------------------------------------------------------------ */
/* function: Get, Set or Clear the .HISTORY EA of a file              */
/*                                                                    */
/* call:     FileHistory GET, filename, NewHistoryStem                */
/*           FileHistory ADD, filename, newHistoryEntry {,newStem}    */
/*           FileHistory SET, filename, CurHistoryStem                */
/*           FileHistory CLEAR, filename                              */
/*                                                                    */
/* where:    GET, ADD, SET, CLEAR                                     */
/*             - action:                                              */
/*                GET - get a list of the current entries             */
/*                ADD - add an entry to the list                      */
/*                SET - replace the EA with a new list                */
/*              CLEAR - clear the whole list                          */
/*           filename                                                 */
/*             - name of the file                                     */
/*           NewHistoryStem                                           */
/*             - stem for the history list entries                    */
/*           newStem                                                  */
/*             - stem for the history list entries                    */
/*           CurHistoryStem                                           */
/*             - stem _with_ the history list entries                 */
/*           newHistoryEntry                                          */
/*             - new entry for the history list                       */
/*               (ASCII string)                                       */
/*                                                                    */
/* returns:  0 - okay                                                 */
/*           1 - file not found                                       */
/*           2 - EA is invalid                                        */
/*           3 - CurHistoryStem.0 is invalid                          */
/*           4 - CurHistoryStem.0.codepage is invalid                 */
/*          -1 - invalid parameter                                    */
/*        else - unexpected error                                     */
/*                                                                    */
/* notes:                                                             */
/*  Do not add the trailing dot to the stem name!                     */
/*  Format of the stems:                                              */
/*    history_stem.0 = number of entries                              */
/*    history_stem.0.codepage = codepage of the EA                    */
/*                              (def.: 0, use default codepage)       */
/*    history_stem.n = entry n                                        */
/*                                                                    */
/*  The format of the .HISTORY EA is:                                 */
/*                                                                    */
/*     EA Type  Code                                                  */
/*              page Count                                            */
/*   +--------------------------------------------------+             */
/*   | EAT_MVMT 0000 0002                               |             */
/*   |          EAT_ASCII 0017  Joe    Created  2/10/88 |             */
/*   |          EAT_ASCII 0017  Harry  Changed  2/11/88 |             */
/*   +--------------------------------------------------+             */
/*              EA Type  length contents (ASCII string)               */
/*                                                                    */
/*  All numeric values are WORDs in INTEL format.                     */
/*                                                                    */
/* (see also Extended Attribute Data Types and EAs used by the WPS)   */
/*                                                                    */
/*  FileHistory uses the prefix 'FH.' for all local variables. The    */
/*  local variables are dropped at the end of the routine!            */
/*                                                                    */
/* (c) 1996 Bernd Schemmer, Germany, EMail: Bernd.Schemmer@gmx.de     */
/*                                                                    */
FileHistory:

                    /* name of the EA to use                          */
                    /* note: change this variable to use the routine  */
                    /*       for the EAs .COMMENTS or .KEYPHRASES.    */
                    /*       In this case you must also delete the    */
                    /*       Codepage related code in this routine.   */
  FH.__EAName = '.HISTORY'

                    /* init the return code                           */
  rc = 0

/* -------------------------- */
                    /* install local error handlers                   */
  SIGNAL ON SYNTAX  NAME FileHistoryEnd
  SIGNAL ON ERROR   NAME FileHistoryEnd
  SIGNAL ON FAILURE NAME FileHistoryEnd
/* -------------------------- */
                    /* get the parameter                              */
  parse upper arg FH.__action , FH.__file , FH.__variable , .

                    /* get the parameter for the ADD action           */
  parse arg  , , FH.__newValue , FH.__tempStem

                    /* check the parameter                            */
  select

                    /* check the action parameter                     */
    when wordPos( FH.__action, 'GET ADD SET CLEAR' ) = 0 then
      rc = -1

                    /* check the parameter for the stem variable      */
    when wordPos( FH.__action, 'GET ADD SET' ) <> 0 & ,
         FH.__variable = '' then
      rc = -1

                    /* check the parameter for the filename           */
    when FH.__file = '' then
      rc = -1

                    /* test, if the file exists                       */
    when stream( FH.__file, 'c', 'QUERY EXISTS' ) = '' then
      rc = 1

                    /* check the number fields in the stem            */
    when FH.__action = 'SET' then
    do
      select

                    /* stem.0 must contain the number of entries      */
        when datatype( value( FH.__variable || '.0' ) ) <> 'NUM' then
          rc = 3
                    /* use the default codepage if the entry          */
                    /* stem.0.codepage is missing                     */
        when symbol( FH.__variable || '.0.CodePage' ) <> 'VAR' then
          call value FH.__variable || '.0.CodePage', 0

                    /* stem.0.codepage must be a numeric value if     */
                    /* it exist                                       */
        when datatype( value( FH.__variable || '.0' ) ) <> 'NUM' then
          rc = 4

        otherwise
          nop
      end /* select */

    end /* when */

    when FH.__action = 'ADD' then
    do
                    /* use the fourth parameter as name of the stem   */
                    /* if entered                                     */
      if FH.__tempStem <> '' then
        FH.__variable = FH.__tempStem
      else
        FH.__variable = 'FH.__tempStem'
    end /* when */

    otherwise
      nop

  end /* select */

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

  if rc = 0 then
  do
                    /* load the necessary REXXUTIL functions          */

                    /* use special REXX names to avoid errors if      */
                    /* another program drops the REXXUTIL functions   */
    call rxFuncAdd 'FH_SysGetEA', 'REXXUTIL', 'SysGetEA'
    call rxFuncAdd 'FH_SysPutEA', 'REXXUTIL', 'SysPutEA'

/* -------------------------- */
                    /* constants for the EA type specifier            */
    FH.__EAT_BINARY       = SwapWord( 'FFFE'x )
    FH.__EAT_ASCII        = SwapWord( 'FFFD'x )
    FH.__EAT_BITMAP       = SwapWord( 'FFFB'x )
    FH.__EAT_METAFILE     = SwapWord( 'FFFA'x )
    FH.__EAT_ICON         = SwapWord( 'FFF9'x )
    FH.__EAT_EA           = SwapWord( 'FFEE'x )
    FH.__EAT_MVMT         = SwapWord( 'FFDF'x )
    FH.__EAT_MVST         = SwapWord( 'FFDE'x )
    FH.__EAT_ANS1         = SwapWord( 'FFDD'x )

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

    if FH.__action = 'CLEAR' then
    do
                    /* clear the history list                         */
                                                             /* v2.80 */
      call FH_SysPutEA FH.__file, FH.__EAName, ''

    end /* if FH.__action = 'CLEAR' then */

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

    if wordPos( FH.__action, 'GET ADD' ) <> 0 then
    do
                    /* read the EA                                    */

                    /* init the stem for the EA values                */
      call value FH.__variable || '.', ''
      call value FH.__variable || '.0' , 0
      call value FH.__variable || '.0.codepage', 0

                    /* read the EA                                    */
      rc = FH_SysGetEA( FH.__file, FH.__EAName, FH.__historyEA )
      if rc = 0 & FH.__historyEA <> '' then
      do
                    /* split the EA into the header fields and the    */
                    /* values                                         */
        parse var FH.__historyEA FH.__historyEAType +2 ,
                                 FH.__historyEACodePage +2,
                                 FH.__historyEACount +2 ,
                                 FH.__historyEAValues

                    /* convert the count value to decimal             */
        FH.__historyEACount = c2d( SwapWord( FH.__HistoryEACount ) )

                    /* check the EA type                              */
        if FH.__historyEAType = FH.__EAT_MVMT then
        do
                    /* save the codepage                              */
          call value FH.__variable || '.0.codepage' ,,
                     c2d( SwapWord( FH.__historyEACodePage ) )

                    /* split the value into separate fields           */
          do FH.__i = 1 to FH.__HistoryEACount while rc = 0

            FH.__HistoryEACurType = substr( FH.__HistoryEAValues, 1, 2 )
            if FH.__HistoryEACurType <> FH.__EAT_ASCII then
              rc = 2    /* invalid EA type                            */
            else
            do
                    /* get the length of this value                   */
              FH.__HistoryEACurLen  = c2d( SwapWord( substr( FH.__HistoryEAValues, 3, 2 ) ) )

              parse var FH.__historyEAValues 5 FH.__HistoryEACurVal,
                                             +( FH.__HistoryEACurLen) ,
                                             FH.__historyEAValues

                    /* save the value into the stem                   */
              call value FH.__variable || '.' || FH.__i ,,
                         FH.__HistoryEACurVal

            end /* else */
          end /* do FH.__i = 1 to c2d( FH.__HistoryEACount ) while rc = 0 */

                    /* save the number of entries in stem.0           */
          if rc = 0 then
            call value FH.__variable || '.0' , FH.__i-1

        end /* if FH.__historyEAType = FH.__EAT_MVST then */
        else
          rc = 2    /* invalid EA type                                */

      end /* if rc = 0 then */

    end /* if wordPos( FH.__action, 'GET ADD' ) <> 0 then */

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

    if FH.__action = 'ADD' & rc = 0 then
    do
                    /* add an entry                                   */

      FH.__i = value( FH.__variable || '.0' ) +1
      call value FH.__variable || '.' || FH.__i , FH.__newValue
      call value FH.__variable || '.0' , FH.__i

    end /* if FH.__action = 'ADD' & rc = 0 then */

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

    if wordPos( FH.__action, 'SET ADD' ) <> 0 & rc = 0 then
    do
                    /* write the EA                                   */

      FH.__newEA = FH.__EAT_MVMT || ,
         SwapWord( right( '00'x || d2c( value( FH.__variable || '.0.codepage' ) ), 2 ) ) || ,
         SwapWord( right( '00'x || d2c( value( FH.__variable || '.0' ) ), 2 ) )

      do FH.__i = 1 to value( FH.__variable || '.0' )
        FH.__curEntry = value( FH.__variable || '.' || FH.__i )

        FH.__newEA = FH.__newEA || ,
                     FH.__EAT_ASCII || ,
                     SwapWord( right( '00'x || d2c( length( FH.__curEntry ) ), 2 ) ) || ,
                     FH.__curEntry
      end /* do FH.__i = 1 to value( FH.__variable || '.0' ) */

                                                             /* v2.80 */
      call FH_SysPutEA FH.__file, FH.__EAName, FH.__newEA
      rc = result

    end /* if wordPos( FH.__action, 'SET ADD' ) <> 0 then */

  end /* if rc = 0 then */

                    /* label for the local error handler              */
FileHistoryEnd:

                    /* drop the REXXUTIL functions                    */
                    /* (possible and necessary because we use unique  */
                    /*  REXX names!)                                  */
    call rxFuncDrop 'FH_SysGetEA'
    call rxFuncDrop 'FH_SysPutEA'

                    /* drop local variables                           */
  drop FH.

RETURN rc

/* ------------------------------------------------------------------ */
/* function: Convert a hexadecimal WORD from LSB format to MSB format */
/*           and vice versa                                           */
/*                                                                    */
/* call:     SwapWord hexadecimal_word                                */
/*                                                                    */
/* where:    hexadecimal_word - input as hexadecimal word             */
/*                                                                    */
/* output:   value in MSB format as hexadecimal word                  */
/*                                                                    */
SwapWord: PROCEDURE
  RETURN strip( translate( "12", arg(1), "21" ) )
</PRE>

====UUDecoding files====
<PRE>
/* ------------------------------------------------------------------ */
/* UUDECODE.CMD - uudecode a file                                     */
/*                                                                    */
/* usage: uudecode encodedFile {>decodedFile}                         */
/*                                                                    */
/* where: encodedFile - file to UUDecode                              */
/*        decodedFile - UUDecoded file                                */
/*                                                                    */
/* authors:                                                           */
/*   Based on original by Stefan Haubenthal 1992/94                   */
/*   Hacked for OS/2 by Graham Bingham (grahamb@iacces.za), Dec 1994  */
/*   Hacked for more speed and accuracy near EOF by Xtian, Dec 1994   */
/*                                                                    */
/* see also base64 encoder                                            */
/* see also base64 decoder                                            */
/* see also Base64 Converting routine                                 */
/* see also Base64 encode and decode routines                         */

/*                                                                    */

                    /* do not allow uninitialized variables           */
  signal on NOVALUE

                    /* get the parameter                              */
  parse arg input

  if input = "" then
  do
                    /* show usage                                     */
    call LineOut, "Usage: UUDECODE encodedFile {>decodedFile}"
    exit 1
  end /* if input = "" then */

  do forever

                    /* search the start of the UUEncoded data         */
    do until datatype( mode ) = "NUM"
      line = linein( input )
      if stream( input, "S" ) <> "READY" then
        exit
      parse value line with "begin" mode dest .
    end /* do until ... */

    say "uudecoding "dest"..."

    if stream( dest, "C", "QUERY EXISTS" ) <> "" then
      "@ERASE" dest "2>NUL 1>NUL"

    call time( "e" )

    do lines=1
      line=linein( input )
      if line = "end" then
        leave
      len=c2d( decode( 1,left( line,1 ) ) )
      if len > 0 then
        call charout dest,decode( len,substr( line,2,trunc((len+2)/3)*4 ) )
    end /* do lines=1 */

    say trunc( lines/time( "e" ) * 60)" lines per minute"

    call stream dest, "C", "CLOSE"
  end /* do forever */

exit 0

/* ------------------------------------------------------------------ */
/* Function: UUDecode a line                                          */
/*                                                                    */
/* Usage:    Decode p1, p2                                            */
/*                                                                    */
/* where:    p1 = ?                                                   */
/*           p2 = ?                                                   */
/*                                                                    */
/* returns: the UUdecoded line                                        */
/*                                                                    */
/* Notes:                                                             */
/*  xx765432 xx107654 xx321076 xx543210 -> 76543210 76543210 76543210 */
/*                                                                    */
DECODE: PROCEDURE /* sub & del */

 bin=c2b( translate( arg(2),xrange("00"x,"5f"x),xrange("20"x,"7f"x) ) )
 do n=1 to length( bin ) by 6
   bin=delstr( bin,n,2 )
 end /* do n=1 ... */

 if length( bin ) < 8 then
   return b2c( right( bin,8,"0" ) )

return b2c( left( bin,arg(1)*8,"0" ) )

/* ------------------------------------------------------------------ */
/* subroutines from DECODE                                            */

c2b: PROCEDURE
  return x2b( c2x( arg(1) ) )

b2c: PROCEDURE
  return x2c( b2x( arg(1) ) )

/* ------------------------------------------------------------------ */
</PRE>

===base64 encoder===
<PRE>
/* ------------------------------------------------------------------ */
/* 2_B64.CMD                                                          */
/*                                                                    */
/* function: base64 encoder                                           */
/*                                                                    */
/*                                                                    */
/* usage: 2_b64.cmd bin_file [target_extension]                       */
/*                                                                    */
/*                                                                    */
/* parameters: bin_file - name of the file to convert                 */
/*             target_extension - extension for the target file       */
/*                                (optional, def.: b64)               */
/*                                                                    */
/*                                                                    */
/* history: 21.06.2003 first release                                  */
/*                                                                    */
/*                                                                    */
/* notes: This code is from Yury Pogrebnyak                           */
/*        (see EMail Addresses)                                       */
/*       Parameter checking was added by Bernd Schemmer               */
/*                                                                    */
/* see also base64 decoder                                            */
/* see also Base64 Converting routine                                 */
/* see also Template for an installation program                      */
/* see also Base64 encode and decode routines                         */
/* see also UUDecoding files                                          */
/* ------------------------------------------------------------------ */

  parse arg in targetExtension

  if targetExtension = '' then
    targetExtension = '.b64'
  else
    if left( targetExtension, 1 ) <> '.' then
      targetExtension = '.' || targetExtension

  parse source . . thisProg
  thisProg = fileSpec( 'N', thisProg )

  if in = '' then
  do
    say thisProg || ' - Error: Parameter missing!'
    say
    say 'Usage: ' || thisProg || ' binary_file_to_convert '
    say ''
    exit 1
  end /* if */

  if stream( in, "C", "QUERY EXISTS" ) = '' then
  do
    say thisProg || ' - Error: File "' || in || '" not found!'
    exit 1
  end /* if */

  if stream( in, "C", "QUERY SIZE" ) = 0 then
  do
    say thisProg || ' - Error: File "' || in || '" is empty!'
    exit 1
  end /* if */

  fileLength = chars( in )
  call charin in,,fileLength

  in_d = result
  in_l = length( in_d )

  parse value filespec( 'n',in ) with out '.'
  call lastpos '\',in
  out = left( in,result ) || out || targetExtension
  '@del 'out' 2>nul 1>>&2'
  in_l = length( in_d )-1
  in_d = x2b( c2x( in_d ) )
  i0 = xrange( "A", "Z" ) || xrange( "a", "z" ) || "0123456789+/"
  v0 = xrange( "00"x, "3f"x )
  a4 = ''

  do ji = 0 to in_l

    select

      when ji//3 = 0 then
      do
        a4 = a4 || '00' || substr( in_d,ji*8+1,6 ) || '00' || substr( in_d,ji*8+7,2 )
        if ji = in_l then
          a4 = a4'0000'
      end /* when ji//3 = 0 then do */

      when ji//3 = 1 then
      do
        a4 = a4 || substr( in_d,ji*8+1,4 ) || '00' || substr( in_d,ji*8+5,4 )
        if ji = in_l then
          a4 = a4'00'
      end /* when ji//3 = 1 then do */

      otherwise
      a4 = a4 || substr( in_d,ji*8+1,2 ) || '00' || substr( in_d,ji*8+3,6 )

    end /* select */

    if ji//57 = 56 | ji = in_l then
    do
      call lineout out,translate( x2c( b2x( a4 ) ),i0,v0 )
      a4 = ''
    end /* if ji//57 = 56 | ji = in_l then do */

  end /* do ji = 0 to in_l */

  call lineout out
exit /* 2_b64.cmd */
</PRE>

===base64 decoder===
<PRE>
/* ------------------------------------------------------------------ */
/* B64_2.CMD                                                          */
/*                                                                    */
/* function: base64 decoder                                           */
/*                                                                    */
/* usage: b64_2.cmd b64_file [target_extension]                       */
/*                                                                    */
/*                                                                    */
/* parameters: b64_file - name of the file to convert                 */
/*             target_extension - extension for the target file       */
/*                                (optional, def.: bin)               */
/*                                                                    */
/* history: 21.06.2003 first release                                  */
/*                                                                    */
/* notes: This code is from Yury Pogrebnyak                           */
/*        (see EMail Addresses)                                       */
/*       Parameter checking was added by Bernd Schemmer               */
/*                                                                    */
/* see also base64 encoder                                            */
/* see also Template for an installation program                      */
/* see also Base64 Converting routine                                 */
/* see also Base64 encode and decode routines                         */
/* see also UUDecoding files                                          */
/* ------------------------------------------------------------------ */

  parse arg in targetExtension

  parse source . . thisProg
  thisProg = fileSpec( 'N', thisProg )

  if in = '' then
  do
    say thisProg || ' - Error: Parameter missing!'
    say
    say 'Usage: ' || thisProg || ' binary_file_to_convert '
    say ''
    exit 1
  end /* if */

  if stream( in, "C", "QUERY EXISTS" ) = '' then
  do
    say thisProg || ' - Error: File "' || in || '" not found!'
    exit 1
  end /* if */

  if stream( in, "C", "QUERY SIZE" ) = 0 then
  do
    say thisProg || ' - Error: File "' || in || '" is empty!'
    exit 1
  end /* if */

  if targetExtension = '' then
    targetExtension = '.bin'
  else
    if right( targetExtension, 1 ) <> '.' then
      targetExtension = '.' || targetExtension

  fileLength = chars( in )
  call charin in,,fileLength

  i64 = translate( result,'0000'x,'0d0a'x )
  call stream in,'c','close'

  if length( i64 ) = 0 then
    exit /* b64_2.cmd */

  parse value filespec( 'n',in ) with out '.'
  call lastpos '\',in
  out = left( in,result ) || out'.bin'
  '@del 'out' 2>nul 1>>&2'
  d_code = xrange( '0'x,'3f'x )
  s_code = xrange( 'A','Z' ) || xrange( 'a','z' ) || '0123456789+/'
  ji = 1
  call pos '0'x,i64

  do while result \= 0

    tmp_s = ''

    if result > ji then
      tmp_s = x2b( c2x( translate( substr( i64,ji,result-ji ),d_code,s_code ) ) )

    ji = result+1

    do while tmp_s \= ''

      parse var tmp_s +2 bin.0 +6 +2 bin.1 +6 +2 bin.2 +6 +2 bin.3 +6 +2 bin.4 +6 +2 bin.5
                      +6  +2 bin.6 +6 +2 bin.7 +6 +2 bin.8 +6 +2 bin.9 +6 +2 bin.10
                      +6 +2 bin.11 +6 tmp_s
      result = bin.0 || bin.1 || bin.2 || bin.3 || bin.4 || bin.5 || bin.6 ||
               bin.7 || bin.8 || bin.9 || bin.10 || bin.11

      if result \= '' then
        call charout out, x2c( b2x( left( result,length( result )%8*8 ) ) )

    end /* do while tmp_s \= '' */

    call pos '0'x,i64,ji

  end /* do while result \= 0 */

  call charout out
exit /* b64_2.cmd */
</PRE>

===Copy a file from HPFS to FAT and vice versa===
<PRE>
/* ------------------------------------------------------------------ */
/* Sample routines to copy a file with a long name from an HPFS       */
/* formatted drive to a FAT formatted drive and vice versa            */
/* preserving the long filename                                       */
/*                                                                    */
/*  Usage to copy from FAT to HPFS:                                   */
/*    COPYLONG HPFS sourceFile destDir                                */
/*                                                                    */
/*  Usage to copy from HPFS to FAT:                                   */
/*    COPYLONG FAT sourceFile destDir                                 */
/*                                                                    */

                    /* load REXXUTIL DLL                              */
                    /* (only SysGetEA and SysPutEA are necessary)     */
  call RxFuncAdd 'SysLoadFuncs', 'REXXUTIL', 'SysLoadFuncs'
  call SysLoadFuncs

                    /* get and check the parameter                    */
  parse arg targetType '"'sourceFile'"' targetDir
  targetType = translate( strip( targetType ) )
  sourceFile = strip( sourceFile )
  targetDir = strip( targetDir )

  select

    when targetType = '/?' | targetType = '-?' then
    do
      say 'Usage to copy from FAT to HPFS:'
      say '  COPYLONG HPFS sourceFile destDir'
      say ''
      say 'Usage to copy from HPFS to FAT:'
      say '  COPYLONG FAT sourceFile destDir'
      say ''

      exit 255
    end /* when */

    when sourceFile = '' | targetDir = '' then
      say 'Error: Invalid call. Use /? for usage'

                    /* copy from FAT to HPFS                          */
    when targetType = 'HPFS' then
      thisRC = copyFromFATToHPFS( sourceFile, targetDir )

                    /* copy from HPFS to FAT                          */
    when targetType = 'FAT' then
      thisRC = copyFromHPFStoFAT( sourceFile, targetDir )

    otherwise
      say 'Error: Invalid call. Use /? for usage'
      thisRC = 255

  end /* select */

return thisRC

/* ------------------------------------------------------------------ */
/* function: copy a file with a long name from an HPFS formatted      */
/*           drive to a FAT formatted drive                           */
/*                                                                    */
/* usage:    thisRC = CopyFromHPFSToFAT( sourceFile destinationDir )  */
/*                                                                    */
/* where:    sourceFile - name of the sourceFile (with or without     */
/*                        path)                                       */
/*           destinationDir - destination directory                   */
/*                                                                    */
/* returns:  0 - okay                                                 */
/*           else error                                               */
/*                                                                    */
/*                                                                    */
CopyFromHPFSToFat: PROCEDURE
  parse arg sourceFile, destDir

  thisRC = -1

  if sourceFile <> '' & destDir <> '' then
  do

    if right( destDir,1 ) <> '\' then
      destDir = destDir || '\'

    thisRC = -2
    if stream( sourceFile, 'c', 'QUERY EXISTS' ) <> '' then
    do
                    /* check if there is an existing EA '.LONGNAME'   */
      longName = GetLongName( sourceFile )

      if longName = '' then
      do
                    /* EA '.LONGNAME' not found or invalid            */

                    /* create the value for the EA '.LONGNAME'        */
        sourceFileName = fileSpec( 'N', sourceFile )
        padString = copies( '00'x, 2 )
        tString = right( padString || d2c( length( sourceFileName ) ),2 )
        tString = translate( '12', tString, '21' )

        newEA = 'FDFF'x || tstring || sourceFileName
      end /* if longName = '' then */

                    /* create the short name for the file             */
      newName = ShortName( sourceFile )

      '@copy ' sourceFile destDir || newName '1>NUL 2>NUL'
      thisRC = rc

      if thisRC = 0 & longName = '' then
      do
                    /* save the original name in the EA '.LONGNAME'   */

        call SysPutEA destDir || newName, '.LONGNAME', newEA
        thisRC = result
      end /* if thisRC = 0 then */

    end /* if stream( sourceFile, 'c', 'QUERY EXISTS' ) <> '' then */
  end /* if sourceFile <> '' & destDir <> '' then */

return thisRC

/* ------------------------------------------------------------------ */
/* function: copy a file with a long name from a FAT formatted        */
/*           drive to an HPFS formatted drive                         */
/*                                                                    */
/* usage:    thisRC = CopyFromFATToHPFS( sourceFile destinationDir )  */
/*                                                                    */
/* where:    sourceFile - name of the sourceFile (with or without     */
/*                        path)                                       */
/*           destinationDir - destination directory                   */
/*                                                                    */
/* returns:  0 - okay                                                 */
/*           else error                                               */
/*                                                                    */
/*                                                                    */
CopyFromFATToHPFS: PROCEDURE
  parse arg sourceFile, destDir

  thisRC = -1

  if sourceFile <> '' & destDir <> '' then
  do
    if right( destDir,1 ) <> '\' then
      destDir = destDir || '\'

    thisRC = -2
    if stream( sourceFile, 'c', 'QUERY EXISTS' ) <> '' then
    do
                    /* def. target name: Use the current name         */
      newName = GetLongName( sourceFile )
      if newName = '' then
        newName = '*'

      '@copy ' sourceFile destDir || newName '1>NUL 2>NUL'
      thisRC = rc
      if thisRC = 0 then
      do
                    /* delete the EA '.LONGNAME'                      */
        call SysPutEA destDir || newName, '.LONGNAME', ''
      end /* if thisRC = 0 then */

    end /* if stream( sourceFile, 'c', 'QUERY EXISTS' ) <> '' then */
  end /* if sourceFile <> '' & destDir <> '' then */

return thisRC

/* ------------------------------------------------------------------ */
/* function: get the value of the EA '.LONGNAME'                      */
/*                                                                    */
/* usage:    longName = GetLongName( sourceFile )                     */
/*                                                                    */
/* where:    sourceFile - name of the sourceFile (with or without     */
/*                        path)                                       */
/*                                                                    */
/* returns:  the longname or '' if the EA is missing or invalid       */
/*                                                                    */
/*                                                                    */
GetLongName: PROCEDURE
  parse arg sourceFile

                    /* init the return code with the default          */
  longName = ''

                    /* check the EA '.LONGNAME'                       */
  tempRC = SysGetEA( sourceFile, '.LONGNAME', EAValue )
  if EAValue <> '' then
  do
                    /* use the value of the EA '.LONGNAME' as new     */
                    /* name                                           */
    parse var EAValue EAType +2 EALength +2 EAValue1
    if EAType = 'FDFF'x then
      longName = strip( EAValue1, 'T', '00'x )

  end /* if EAValue <> '' then */

return longName

/* ------------------------------------------------------------------ */
/* function: dummy routine to create a unique file name               */
/*                                                                    */
/* usage:    newName = ShortName( sourceFile destinationDir )         */
/*                                                                    */
/* where:    sourceFile - name of the sourceFile (with or without     */
/*                        path)                                       */
/*           destinationDir - destination directory                   */
/*                                                                    */
/* returns:  the new name                                             */
/*                                                                    */
/*                                                                    */
/* notes:    Replace this routine with a routine to get a unique name */
/*           in a real program!!!                                     */
/*           (for example Get a name for a temporary file)            */
/*                                                                    */
ShortName: PROCEDURE
  parse arg sourceFile, destDir

  say 'Enter the shortname for the file "' || sourceFile || '"'
  say '(Destination directory is "' || destDir || '"):'

  thisRC = strip( lineIN() )

return thisRC
</PRE>

===Changing file attributes===
====Changing the file creation time stamp====
To change the file creation time stamp you must delete and recreate the file:
<PRE>
  testFile = 'C:\TEMP\TEST'
                    /* read the file                                  */
  fileContents = CharIn( testFile,1 , chars( testFile ) )
                    /* close the file                                 */
  call stream testFile, 'c', 'CLOSE'
                    /* delete the file                                */
  'del ' testFile '2>NUL 1>NUL'
                    /* recreate the file                              */
  call CharOut testFile, fileContents
                    /* close the file                                 */
  call stream testFile, 'c', 'CLOSE'
</PRE>
This code will set the creation time stamp to the current time and date. If you need other values for this time stamp, you must change the current date and time before executing the code and restore it afterwards. Note that a time change is always global for the whole system!

You cannot read the creation time stamp with plain REXX. You need an external REXX DLL, like for example REXXLIB from Quercus Systems (see Internet - Web Pages), for this task.

====Changing the last read time stamp====
You can change the last read time stamp by opening the file for reading:
<PRE>
                    /* set the last read time stamp to the current    */
                    /* date/time                                      */
  testFile = 'C:\TEMP\TEST'
  call stream testFile, 'c', 'OPEN READ'
  call stream testFile, 'c', 'CLOSE'
</PRE>
Note that you cannot read the last read time stamp with plain REXX. You need an external REXX DLL, like for example REXXLIB from Quercus Systems (see Internet - Web Pages), for this task.

====Changing the last write time stamp====
To change the last write time stamp you can use the "poor mans" touch:
<PRE>
 testFile = 'C:\TEMP\TEST'
 'copy ' || testFile || '+,,' '2>NUL 1>NUL'
</PRE>
Note that the date and time retrieved with stream or with SysFileTree is always the last write time stamp.

====Changing the file attributes====
To change one or more of the file attributes you can either use the OS/2 command ATTRIB or the REXXUTIL function SysFileTree:
<pre>
/* set the system and readonly attribute for the file C:\TEST         */

                    /* - using ATTRIB                                 */
  'attrib' '+r +s' 'C:\TEST'

                    /* - using SysFileTree                            */
  call RxFuncAdd 'SysFileTree', 'REXXUTIL', 'SysFileTree'
  call SysFileTree 'C:\TEST', dummyStem, 'F', '*****', '***++'
</PRE>

====Changing the extended attributes of a file====
To read and write the extended attributes of a file you can use the REXXUTIL functions SysGetEA and SysPutEA (and SysQueryEAList in Object-Oriented REXX).
To delete all extended attributes you can use the OS/2 command EAUTIL:
 'eautil c:\test nul /s'
(see also Extended Attributes used by the WPS, Extended Attribute Data Types, Extract the icon from the EAs, and The function SysPutEA()) 

===Copy a file with a progress indicator===
<PRE>
/* ------------------------------------------------------------------ */
/* Sample routines to copy a file and show the progress of the        */
/* copy process                                                       */
/*                                                                    */
/*                                                                    */

  say 'Please enter the source filename:'
  sourceFile = lineIn()

  say 'Please enter the target filename:'
  targetFile = lineIn()

  call CopyFileWithStatusBar sourceFile, targetFile
exit

/* ------------------------------------------------------------------ */
/* function: copy a file and show a progress indicator                */
/*                                                                    */
/* usage:    thisRC = CopyFileWithStatusbar( sourceFile, targetFile ) */
/*                                                                    */
/* where:    sourceFile - name of the sourceFile                      */
/*           targetfile - name of the target file                     */
/*                                                                    */
/* returns:  0 - okay                                                 */
/*           else error                                               */
/*                                                                    */
/* Notes:                                                             */
/*                                                                    */
/* There is no error checking in this routine!                        */
/*                                                                    */
CopyFileWithStatusBar: PROCEDURE
  parse arg sourceFile, targetFile

  noOfPackets = 75
                    /* get the size of the file                       */
  fileSize = chars( sourceFile )

                    /* calculate the packet size                      */
  packetsize = fileSize % noOfPackets

                    /* do not forget the rest - if any                */
  lastPacket = fileSize // noOfPackets

                    /* open the input and the output file             */
  thisRC1 = stream( sourceFile, 'c', 'OPEN READ' )  = 'READY:'
  thisRC2 = stream( targetFile, 'c', 'OPEN WRITE' ) = 'READY:'

                    /* init the status bar                            */
  call CharOut , copies( 'B0'x , noOfPackets ) || '0D'x

                    /* copy the file in # steps                       */
  do i = 1 to noOfPackets

    call CharOut,  'DB'x

    call CharOut targetFile, charin( sourceFile, , packetSize )
  end /* do i = 1 to noOfPackets */

                    /* do not forget the last packet                  */
  if lastPacket <> 0 then
    call CharOut targetFile, charin( sourceFile, , lastPacket )

                   /* close the files                                 */
  call stream sourceFile, 'c', 'CLOSE'
  call stream targetFile, 'c', 'CLOSE'

return 0
</PRE>

===Add default extension===
<PRE>
/* ------------------------------------------------------------------ */
/* function: Add a default extension to a filename if necessary       */
/*                                                                    */
/* usage:    newFileName = CheckExtension( fileName, extension )      */
/*                                                                    */
/* where:    fileName = the filename to check                         */
/*           extension = default extension                            */
/*                                                                    */
/* returns:  the filename with extension                              */
/*                                                                    */
CheckExtension: PROCEDURE expose (exposeList)
  parse arg fileName, extension

                        /* init the return code                       */
  thisRC = fileName

  if fileName <> '' & extension <> '' then
  do
    dotPos = lastpos( '.', fileName )
    backslashPos = lastpos( '\', fileName )

    if ( dotPos <= backslashPos ) then
      thisRC  = fileName || extension
  end /* if fileName <> '' & extension <> '' then */

return thisRC
</PRE>

==Runtime tests & methods==
===Simulate the INCLUDE command===
see the procedures Include and TryInclude in Template for a REXX program 

===Check if a program is in the macro space===
 <PRE>
/* check if this program is executed from within the macrospace       */
/* (see also LoadMac.cmd)                                             */

  if InMacroSpace() = 1 then
    say "This program is executed from within the macro space"
  else
    say "This program is NOT executed from within the macro space"

exit 0

/* ------------------------------------------------------------------ */
/* function: Check if the program is in the macrospace                */
/*                                                                    */
/* call:     InMacroSpace                                             */
/*                                                                    */
/* returns:  1 - yes                                                  */
/*           0 - no                                                   */
/*                                                                    */
InMacroSpace: PROCEDURE

  SIGNAL ON SYNTAX   NAME NotInMacroSpace
  inMacroSpace = 1

  dummy = sourceLine( 1 )
  inMacroSpace = 0

NotInMacroSpace:

  if inMacroSpace = 1 then
  do
                        /* program seems to be in the macro space     */
                        /* do a second check to be sure               */
    parse source . . thisFile
    if fileSpec( "drive", thisFile ) <> '' then
      inMacroSpace = 0  /* Oops, we are not in the macro space        */
  end /* if inMacroSpace = 1 */

RETURN inMacroSpace
</PRE>

===Get a line number at runtime - 1 -===
<PRE> 
/* code sequence to get the no. of a sourceline at runtime            */
/* Note that this code also functions in compiled REXX programs       */
/* and in REXX programs loaded in the macro space.                    */
/* Usage example:                                                     */
/* You can use this technique in your programs to write an error      */
/* handler which ignores errors in some lines but not in all.         */
/* (see the routines I!.__CallUserProc and I!.__ErrorAbort in     */
/* the TEMPLATE.CMD.)                                                 */

/** DO NOT CHANGE, ADD OR DELETE ANY OF THE FOLLOWING FOUR LINES!    **/
  SIGNAL I!.__CallUserProc1
I!.__CallUserProc1:
  LineNo = sigl+2     /* no. of THIS line                             */
  say "This is the line no. " || LineNo+1 || " of the source code."
/** DO NOT CHANGE, ADD OR DELETE ANY OF THE PRECEDING FOUR LINES!    **/
</PRE>

===Get a line number at runtime - 2 -===
<PRE>
/* another code sequence to get the no. of a sourceline at runtime    */
/* Note that this code also functions in compiled REXX programs       */
/* and in REXX programs loaded in the macro space.                    */
/* Usage example:                                                     */
/* You can use this technique in your programs to write an error      */
/* handler which ignores errors in some lines but not in all.         */
/* (see the routines I!.__CallUserProc and I!.__ErrorAbort in     */
/* the TEMPLATE.CMD.)                                                 */

  say "This is the line no. " || GetLineNo() || " of the program."

exit

/* sample routine to return the line number with the call             */
GetLineNo: PROCEDURE expose sigl
  return sigl
</PRE>

===Leave an outer loop from an inner loop===
<PRE>
/* code sequence showing a technique to leave an outer loop in        */
/* an inner loop                                                      */

  do i=1 until 1=0              /* i is a dummy variable for the      */
                                /* leave command                      */
                                /* UNTIL 1=0 simulates "FOREVER"      */
    do j=4 to 45
      r = 1
      do while ( r.j <> t.j )
        r = r + 1
        if r.j = "EXIT" then
          leave i               /* abort the UNTIL loop               */
      end /* do while ( r.j <> t.j ) */
    end  /* do j=4 to 45 */
  end /* do i=1 UNTIL 1=0 */
</PRE>

===Call another REXX program (OS/2 v2.1)===
<PRE>
/* code sequence to call a program from within a REXX program if      */
/* the first part of the path of the program is stored in a           */
/* variable (only necessary if you are using OS/2 2.1)                */

                                /* create an environment variable     */
  dummy=value( "drive", "C:", "OS2ENVIRONMENT" )

  "%drive%\os2\attrib *.*"
                                /* delete the environment variable    */
  dummy=value( "drive", "", "OS2ENVIRONMENT" )
</PRE>

===Call another CMD===
<PRE>
/* code sequence to call another CMD file from within an CMD file     */

  cmdLine=progDrive || progPath || progName || " " || ProgParm
  "cmd /c " cmdLine
                        /* "RC" contains the return code              */
  if rc <> 0 & rc <> "RC" then
    say "Error: The program ends with RC = " || rc
</PRE>

===Call another CMD by value===
<PRE>
/* code sequence to call another CMD by value                         */

  cmdPath = "E:\DEVELOP\REXX"

  iLine = 'call "' || cmdPath || '\MYFUNC"'
  interpret iLine

/* Note:                                                              */
/*  call cmdPath || "\MYFUNC"                                         */
/* won't work                                                         */
</PRE>

===Call by value===
In classic REXX it is not possible to use a variable as parameter for the call statement (in Object-Oriented REXX it is; see New features in Object REXX that are useful in Classic REXX programs also)

To get around this you can use either the interpret statement or a combination of the call and the signal statement.

The following code is an example for the usage of the interpret statement. This code works for all type of functions and subroutines:
<PRE>
/* example using the interpret statement                              */

/* ------------- example for calling a sub routine ------------------ */

  '@cls'
                    /* name of the routine to call                    */
  funcName = 'proc1'
                    /* names of the global variables used by the      */
                    /* function                                       */
  exposeList = ''
                    /* parameter for the routine                      */
  parameter1 = '11'
  parameter2 = '22'

  say ''
  say '[main] Now calling the routine "' || funcName || '" ...'
  say '[main] The parameter are "' || parameter1 || '" and "'|| parameter2 || '"'

                    /* now call the routine                           */
  interpret call funcName parameter1 ',' parameter2

/* ------------- example for calling a function --------------------- */

                    /* name of the function to call                   */
  funcName = 'Func2'
                    /* names of the global variables used by the      */
                    /* function                                       */
  exposeList = ''
                    /* parameter for the function                     */
  parameter1 = '33'
  parameter2 = '44'

  say ''
  say '[main] Now calling the function "' || funcName || '" ...'
  say '[main] The parameter are "' || parameter1 || '" and "'|| parameter2 || '"'

                    /* now call the function                          */
  interpret 'thisResult = ' funcName || '(' parameter1 ',' parameter2 ')'

  say '[main] The function "' || funcName || '" returned: "' || thisResult || '".'

/* ------------- example for calling a DLL function ----------------- */

                    /* name of the function to call                   */
  funcName = 'SysCurPos'
                    /* name of the global variables used by the       */
                    /* function                                       */
  exposeList = ''
                    /* parameter for the DLL function                 */
  parameter1 = '21'
  parameter2 = '0'

  say ''
  say '[main] Now calling the DLL function "' || funcName || '" ...'
  say '[main] The parameter are "' || parameter1 || '" and "'|| parameter2 || '"'

                    /* now call the DLL function                      */
  interpret 'thisResult = ' funcName || '(' parameter1 ',' parameter2 ')'

  say '[main] The function "' || funcName || '" returned: "' || thisResult || '".'


/* ------------- example for calling a builtin function ------------- */

                    /* name of the function to call                   */
  funcName = 'abs'
                    /* names of the global variables used by the      */
                    /* function                                       */
  exposeList = ''
                    /* parameter for the builtin function             */
  parameter1 = '-2.121'

  say ''
  say '[main] Now calling the builtin function "' || funcName || '" ...'
  say '[main] The parameter is "' || parameter1 || '"'

                    /* now call the DLL function                      */
  interpret 'thisResult = ' funcName || '(' parameter1 ')'

  say '[main] The function "' || funcName || '" returned: "' || thisResult || '".'

exit

/* ------------------------------------------------------------------ */
/* sample subroutine                                                  */
/*                                                                    */
/* Note: The first parameter is the name of the function              */
/*                                                                    */
proc1: PROCEDURE expose (exposeList)
  parse arg arg1, arg2
  say '[proc1] This is proc1'
  say '[proc1] The first parameter is "' || arg1 || '"'
  say '[proc1] The second parameter is "' || arg2 || '"'
return

/* ------------------------------------------------------------------ */
/* sample function                                                    */
/*                                                                    */
/* Note: The first parameter is the name of the function              */
/*                                                                    */
FUNC2: PROCEDURE expose (exposeList)
  parse arg  arg1, arg2
  say '[func2] This is func2'
  say '[func2] The first parameter is "' || arg1 || '"'
  say '[func2] The second parameter is "' || arg2 || '"'
return 2
</PRE>

The following code is an example for the usage of the combination of the call and the signal statement. This code works only for functions and sub routines in the program, for builtin functions and for functions from a DLL (see also Redefinition of functions from a DLL and Redefinition of internal functions):

<PRE> 
/* example using the combination of the call and the signal statement */
/* (based on code found in a public newsgroup)                        */

/* ------------- example for calling a sub routine ------------------ */

  '@cls'
                    /* name of the routine to call                    */
  funcName = 'proc1'

                    /* names of the global variables used by the      */
                    /* called routine                                 */
  exposeList = ''
                    /* parameter for the routine                      */
  parameter1 = '11'
  parameter2 = '22'

  say ''
  say '[main] Now calling the routine "' || funcName || '" ...'
  say '[main] The parameter are "' || parameter1 || '" and "'|| parameter2 || '"'

                    /* now call the routine                           */
  call Dispatcher funcName , parameter1 , parameter2

/* ------------- example for calling a function --------------------- */

                    /* name of the function to call                   */
  funcName = 'func2'
                    /* names of the global variables used by the      */
                    /* function                                       */
  exposeList = ''
                    /* parameter for the function                     */
  parameter1 = '33'
  parameter2 = '44'

  say ''
  say '[main] Now calling the function "' || funcName || '" ...'
  say '[main] The parameter are "' || parameter1 || '" and "'|| parameter2 || '"'

                    /* now call the function                          */
  thisResult = Dispatcher( funcName , parameter1, parameter2 )

  say '[main] The function "' || funcName || '" returned: "' || thisResult || '".'

/* ------------- example for calling a DLL function ----------------- */

                    /* name of the function to call                   */
  funcName = 'SysCurPos'
                    /* names of the global variables used by the      */
                    /* function                                       */
  exposeList = ''
                    /* parameter for the DLL function                 */
  parameter1 = '21'
  parameter2 = '0'

  say ''
  say '[main] Now calling the DLL function "' || funcName || '" ...'
  say '[main] The parameter are "' || parameter1 || '" and "'|| parameter2 || '"'


                    /* now call the DLL function                      */
  thisResult = Dispatcher( funcName , parameter1, parameter2 )

  say '[main] The function "' || funcName || '" returned: "' || thisResult || '".'

/* ------------- example for calling a builtin function ------------- */

                    /* name of the function to call                   */
  funcName = 'abs'
                    /* names of the global variables used by the      */
                    /* function                                       */
  exposeList = ''
                    /* parameter for the builtin function             */
  parameter1 = '-2.121'

  say ''
  say '[main] Now calling the builtin function "' || funcName || '" ...'
  say '[main] The parameter is "' || parameter1 || '"'

                    /* now call the builtin function                  */
  thisResult = Dispatcher( funcName , parameter1, parameter2 )

  say '[main] The function "' || funcName || '" returned: "' || thisResult || '".'

exit

/* ------------------------------------------------------------------ */
/* help routine                                                       */
/*                                                                    */
/* usage: Dispatcher name_of_the_routine {parameter_for_the_routine}  */
/*                                                                    */
/* Note: The parameter for the signal statement must be in UPPERCASE! */
/*                                                                    */
Dispatcher: PROCEDURE expose (exposeList)
  parse upper arg label
  signal value label

/* ------------------------------------------------------------------ */
/* sample subroutine                                                  */
/*                                                                    */
/* Note: The first parameter is the name of the function              */
/*       You can not use PROCEDUE here!                               */
/*                                                                    */
proc1:
  parse arg , arg1, arg2
  say '[proc1] This is "' || arg(1)  || '".'
  say '[proc1] The first parameter is "' || arg1 || '"'
  say '[proc1] The second parameter is "' || arg2 || '"'
return

/* ------------------------------------------------------------------ */
/* sample function                                                    */
/*                                                                    */
/* Note: The first parameter is the name of the function              */
/*       You can not use PROCEDUE here!                               */
/*                                                                    */
FUNC2:
  parse arg , arg1, arg2
  say '[func2] This is "' || arg(1)  || '".'
  say '[func2] The first parameter is "' || arg1 || '"'
  say '[func2] The second parameter is "' || arg2 || '"'
return 2

/* ------------------------------------------------------------------ */
/* sample placeholder for builtin function                            */
/*                                                                    */
/* Note: The first parameter is the name of the function              */
/*       You can not use PROCEDUE here!                               */
/*                                                                    */
                        /* new SysCurPos function                     */
SysCurPos:
  parse arg , p1,p2

  say '[SysCurPos] This is "' || arg(1)  || '".'

  say '[SysCurPos] The first parameter is "' || p1 || '"'
  say '[SysCurPos] The second parameter is "' || p2 || '"'

                        /* check the type of the parameter            */
  if datatype( p1 ) <> "NUM" | datatype( p2 ) <> "NUM" then
    thisRC = "Invalid parameter!"
  else
  do
                        /* load the original function if not already  */
                        /* loaded                                     */
    if RxFuncQuery( "SysCurPos" ) then
      call RxFuncAdd "SysCurPos", "REXXUTIL", "SysCurPos"

                        /* call the original function                 */
    thisRC = "SYSCURPOS"( p1,p2 )
  end /* else */
RETURN thisRC

/* ------------------------------------------------------------------ */
/* sample placeholder for a builtin function                          */
/*                                                                    */
/* Note: The first parameter is the name of the function              */
/*       You can not use PROCEDUE here!                               */
/*                                                                    */
                        /* new abs function                           */
abs:
  parse arg , p1
  say '[abs] This is "' || arg(1)  || '".'
  say '[abs] The first parameter is "' || p1 || '"'

                        /* note: The name of the builtin functio must */
                        /*       be in uppercase!                     */
  return "ABS"(p1)
</PRE>

===Get the invocation syntax===
<PRE>
/*                                                                    */
/* sample REXX code to show how to get the invocation syntax          */
/* (PARSE SOURCE always returns the fully qualified name of the       */
/*  REXX program)                                                     */
/*                                                                    */
/* Using this code, you can determine what command the users entered  */
/* to call your REXX program.                                         */
/*                                                                    */
/* e.g. TEST.CMD or .\TEST.CMD or D:\REXX\TEST.CMD                    */
/*                                                                    */
/* To test this code call it with different name/path combinations    */
/* e.g.:                                                              */
/*                                                                    */
/*  test.cmd                                                          */
/*  .\test.cmd                                                        */
/*  or                                                                */
/*  d:\rexx\test.cmd                                                  */
/*                                                                    */
/* Caution: This code works only for REXX programs called from        */
/*          CMD.EXE - not for REXX programs called from other         */
/*          REXX programs!                                            */
/*          (see also Get the name of the MAIN program called)        */
/*                                                                    */

                    /* check if this program was called as COMMAND    */
                    /* or as SUBROUTINE                               */
  parse source . callType .
  if callType <> "COMMAND" then
  do
    say "Error: This method only works if this program was" ,
        "called from the command line!"
    exit
  end /* if callType <> "COMMAND" then */

                    /* flush the REXX queue                           */
  do while queued() <> 0; parse pull; end

                    /* copy the invocation syntax into the queue      */
  '@ECHO %0| rxqueue'

  parse pull invocation

  parse source . . thisFile

  say 'PARSE SOURCE says "'  || thisFile || '"'
  say 'The program was called via "' || invocation || '"'
exit 0
</PRE>

===Get the name of the MAIN REXX program called===
<PRE>
/*                                                                    */
/* Sample REXX code to show how to get the name of the main REXX      */
/* program executed by the user.                                      */
/*                                                                    */
/*                                                                    */
/* For example if the user calls TEST2.CMD and TEST2.CMD then calls   */
/* TEST1.CMD, and finally TEST1.CMD calls this program, this progarm  */
/* will print TEST2.CMD to the screen.                                */
/* (see also Get the invocation syntax)                               */
/*                                                                    */
/* To test this code do                                               */
/*                                                                    */
/* - save it into a file named TEST.CMD                               */
/*                                                                    */
/* - create another REXX program named TEST1.CMD containing the       */
/*   statements:                                                      */
/*                                                                    */
/*   parse source . . thisFile                                        */
/*   say 'This is "' || thisFile || '"'                               */
/*   CALL TEST.CMD                                                    */
/*                                                                    */
/* - create another REXX program named TEST2.CMD containing the       */
/*   statements:                                                      */
/*                                                                    */
/*   parse source . . thisFile                                        */
/*   say 'This is "' || thisFile || '"'                               */
/*   CALL TEST1.CMD                                                   */
/*                                                                    */
/* Then call TEST2.CMD with and without parameter to test this code   */
/*                                                                    */

                    /* check if this program was called as COMMAND    */
                    /* or as SUBROUTINE                               */
  parse source . callType .
  if callType <> "SUBROUTINE" then
  do
    say "Error: This method only works if this program was" ,
        "called from another REXX program!"
    exit
  end /* if callType <> "COMMAND" then */

                    /* flush the REXX queue                           */
  do while queued() <> 0; parse pull; end

                    /* copy the name of the main CMD into the queue   */
  '@ECHO %0| rxqueue'

  parse pull invocation

                    /* copy the parameter for the main CMD into the   */
                    /* queue                                          */
  '@ECHO "%1 %2 %3 %4 %5 %6 %7 %8 %9"|rxqueue'

  parse pull parameter
  parameter = strip( strip( parameter, 'B', '"' ) )

  parse arg thisArgs
  parse source . . thisFile
  say 'This is "' || thisFile || '"'

  say '  PARSE SOURCE says "'  || thisFile || '"'
  say '  PARSE ARG says "' || thisArgs || '"'

  say '  The main program called was "' || invocation || '"'
  say '  The parameter for the main program are "' || parameter || '"'

exit 0
</PRE>

===Get the parameters as seen by CMD.EXE===
<PRE> 
/*                                                                    */
/* sample REXX code to show how to get the parameter without          */
/* using the REXX functions (and therefore avoiding the restrictions  */
/* of the REXX interpreter)                                           */
/*                                                                    */
/* Caution: This code works only for REXX programs called from        */
/*          CMD.EXE - not for REXX programs called from other         */
/*          REXX programs!                                            */
/*                                                                    */
/* see also Get the parameters as seen by CMD.EXE - 2 -               */
/*                                                                    */

                    /* check if this program was called as COMMAND    */
                    /* or as SUBROUTINE                               */
  parse source . callType .
  if callType <> "COMMAND" then
  do
    say "Error: This method only works if this program was" ,
        "called from the command line!"
    exit
  end /* if callType <> "COMMAND" then */

                    /* flush the REXX queue                           */
  do while queued() <> 0; parse pull; end

                    /* copy the parameters 1 to 9 into the queue      */
                                                             /* v3.20 */
  '@IF NOT %1. == . ECHO %1 %2 %3 %4 %5 %6 %7 %8 %9| rxqueue'
                    /* get the parameter via the alternate method     */

   if queued() <> 0 then                                     /* v3.20 */
     parse pull CMDparameter                                 /* v3.20 */
   else                                                      /* v3.20 */
     CMDParameter = ''                                       /* v3.20 */

   CMDParameter = strip( CMDParameter )

  parse pull CMDparameter
  CMDParameter = strip( CMDParameter )

                    /* get the parameter via the REXX features        */
  parse arg REXXParameter

  say 'Parameter retrieved with PARSE ARG are:       "' || REXXParameter || '"'
  say 'Parameter retrieved via alternate method are: "' || CMDparameter || '"'
exit 0
</PRE>

===Get the parameters as seen by CMD.EXE - 2 -===
<PRE>
/*                                                                    */
/* sample REXX code to show how to get the parameter without          */
/* using the REXX functions (and therefore avoiding the restrictions  */
/* of the REXX interpreter)                                           */
/*                                                                    */
/* Caution: This code works only for REXX programs called from        */
/*          CMD.EXE - not for REXX programs called from other         */
/*          REXX programs!                                            */
/*                                                                    */
/* see also Get the parameters as seen by CMD.EXE                     */
/*                                                                    */

                    /* check if this program was called as COMMAND    */
                    /* or as SUBROUTINE                               */
  parse source . callType .
  if callType <> "COMMAND" then
  do
    say "Error: This method only works if this program was" ,
        "called from the command line!"
    exit
  end /* if callType <> "COMMAND" then */

                    /* copy the parameters 1 to 9 into an environment */
                    /* variable                                       */
  '@SETLOCAL'
  '@SET MYVAR=%1 %2 %3 %4 %5 %6 %7 %8 %9'
                    /* get the parameter via the alternate method     */
  CMDParameter = strip( value( 'MYVAR',, 'OS2ENVIRONMENT' ) )
  '@ENDLOCAL'

                    /* get the parameter via the REXX features        */
  parse arg REXXParameter

  say 'Parameter retrieved with PARSE ARG are:       "' || REXXParameter || '"'
  say 'Parameter retrieved via alternate method are: "' || CMDparameter || '"'
exit 0
</PRE>

===Check if a program is running (using RXU.DLL)===
<PRE>
/* ------------------------------------------------------------------ */
/* function: isrun.cmd checks if a specific program is running        */
/*                                                                    */
/* Usage:    isrun exe_name                                           */
/*                                                                    */
/* returns:  0 - program is not running                               */
/*           1 - program is running                                   */
/*           2 - usage error                                          */
/*         255 - cannot load the DLL RXU                              */
/*                                                                    */
/*                                                                    */
/* Notes:    This program needs Dave Boll's DLL RXU.DLL               */
/*                                                                    */
/* Author:   Michael Platschek (see EMail Addresses)                  */
/*           Based on the program PI2.CMD from the RXU package        */
/*                                                                    */
/* see also Check if a program is running (using PSTAT)               */
/*                                                                    */
/*           You cannot check if a .CMD file is running with this     */
/*           routine!                                                 */
/*                                                                    */
                    /* get the parameter                              */
  parse upper arg progname
  if words( progname ) = 0 | words( progname ) > 1 | ,
     progname = '/?' | progname = '?' then
    SIGNAL PARAERR

  if rxfuncquery( 'rxqprocstatus' ) then
  do
                    /* load RXU DLL                                   */
    call rxfuncadd 'rxuinit', 'rxu', 'rxuinit'
    call rxuinit
  end /* if */

                    /* install an error handler for SYNTAX errors     */
  SIGNAL on SYNTAX Name DLLLoadError

                    /* get the stem with the process information      */
  call rxqprocstatus 'q.'

                    /* compare the name of the searched program with  */
                    /* all members of the stem with the running       */
                    /* processes                                      */
  do i = 1 to q.0P.0
    if progname = translate( filespec( 'n', q.0P.i.6 ) ) then
    do
                    /* program found                                  */
      RETURN 1
    end /* if */
  end /* do */

                    /* program NOT found                              */
RETURN 0

/* ------------------------------------------------------------------ */
/* show the usage help                                                */
PARAERR:
  say 'ISRUN <PROGRAMMNAME.EXT>'
  say ' Return-Codes:'
  say '   0 = program not running'
  say '   1 = program is running'
  say '   2 = invalid call'
  say ' 255 = Error loading the DLL RXU'
RETURN 2

/* ------------------------------------------------------------------ */
DLLLoadError:
  say 'Error: Cannot load the DLL RXU!'
RETURN 255

/* ------------------------------------------------------------------ */
</PRE>

===Check if a program is running (using PSTAT)===
<PRE>
/* ------------------------------------------------------------------ */
/* function: isrun.cmd checks if a specific program is running        */
/*                                                                    */
/* Usage:    isrun exe_name                                           */
/*                                                                    */
/* where:    exe_name                                                 */
/*             - name of the EXE (with or without path)               */
/*                                                                    */
/* returns:  0 - program is not running                               */
/*           1 - program is running                                   */
/*           2 - usage error                                          */
/*                                                                    */
/*                                                                    */
/* Notes:    This program needs the program PSTAT to be in a          */
/*           directory in the PATH                                    */
/*                                                                    */
/*           You cannot check if a .CMD file is running with this     */
/*           routine!                                                 */
/*                                                                    */
/* see also Check if a program is running (using RXU.DLL)             */
/*                                                                    */
                    /* init the return code                           */
  thisRC = 0

                    /* get the parameter                              */
  parse upper arg progname
  if progName = '' | pos( '?', progName ) <> 0 then
  do
                    /* show the usage help                            */
    say 'Usage: isrun exeName'
    thisRC = 2
  end /* if progName = '' | pos( '?', progName ) <> 0 then */

  if thisRC = 0 then
  do
                    /* flush the REXX queue                           */
    do while queued() <> 0; parse pull; end;

                    /* add the default extension to the program name  */
                    /* if necessary                                   */
    i = lastPos( '.', progName )
    j = lastPos( '\', progName )
    if ( i = 0 ) | ( i < j ) then
      progName = progName || '.EXE'

                    /* call PSTAT to get the process information      */
    '@pstat /c | rxqueue'

                    /* init the stem with the names of the running    */
                    /* programs                                       */
    processList.0 = 0

                    /* extract the process information from the PSTAT */
                    /* output                                         */
    do while queued() <> 0
      curLine = lineIn( 'QUEUE:' )

      parse upper var curLine ,
        1 ProcessID 11 ParentProcessID 21 SessionID 31 exeName .

                    /* check if this is a valid entry                 */
      if pos( '\', exeName ) <> 0 then
      do
                    /* entry is valid -> add it to the stem           */
        i = processList.0+1
        processList.i = strip( exeName )
        processList.0 = i
      end /* if datatype( exeName ) <> 'NUM' then */

    end /* do while queued() <> 0 */

                    /* compare the name of the searched program with  */
                    /* all members of the stem with the running       */
                    /* processes                                      */
    do i = 1 to processList.0 while thisRC = 0
      if pos( '\', progName )= 0 then
        thisRC = (progname = translate( filespec( 'n', processList.i ) ) )
      else
        thisRC = ( progName = processList.i )
    end /* do i = 1 to processList.0 */
  end /* if thisRC = 0 then */

RETURN thisRC

/* ------------------------------------------------------------------ */
</PRE>

===Debug: Print information about a procedure===
This is a simple routine to print some information about a function. This routine uses only dynamically retrieved information so there is no need to change anything if defining a new routine.

This is especially useful for debugging.

Note that this routine will NOT work in "compiled" REXX programs because of the missing source code. It's only ment for debugging your REXX programs.

Sample Output:
<PRE>
[+++DEBUG+++] Inside "RoutineA" (Line 12)
[+++DEBUG+++]   Called from line 3.
This is RoutineA
[+++DEBUG+++] Inside "RoutineB" (Line 20)
[+++DEBUG+++]   Called from line 16.
This is RoutineB
[+++DEBUG+++] Inside "RoutineC" (Line 25)
[+++DEBUG+++]   Called from line 17.
This is RoutineC
[+++DEBUG+++] Inside "RoutineB" (Line 20)
[+++DEBUG+++]   Called from line 29.
This is RoutineB
[+++DEBUG+++] Inside "RoutineB" (Line 20)
[+++DEBUG+++]   Called from line 4.
This is RoutineB
[+++DEBUG+++] Inside "RoutineC" (Line 25)
[+++DEBUG+++]   Called from line 5.
This is RoutineC
[+++DEBUG+++] Inside "RoutineB" (Line 20)
[+++DEBUG+++]   Called from line 29.
This is RoutineB
[+++DEBUG+++] Inside "RoutineD" (Line 32)
[+++DEBUG+++]   Called from line 6.
This is RoutineD
[+++DEBUG+++] Inside "RoutineA" (Line 12)
[+++DEBUG+++]   Called from line 36.
This is RoutineA
[+++DEBUG+++] Inside "RoutineB" (Line 20)
[+++DEBUG+++]   Called from line 16.
This is RoutineB
[+++DEBUG+++] Inside "RoutineC" (Line 25)
[+++DEBUG+++]   Called from line 17.
This is RoutineC
[+++DEBUG+++] Inside "RoutineB" (Line 20)
[+++DEBUG+++]   Called from line 29.
This is RoutineB
[+++DEBUG+++] Inside "RoutineC" (Line 25)
[+++DEBUG+++]   Called from line 37.
This is RoutineC
[+++DEBUG+++] Inside "RoutineB" (Line 20)
[+++DEBUG+++]   Called from line 29.
This is RoutineB
</PRE>
 
<PRE>
/* ------------------------------------------------------------------ */
/* simple debugging routine to print data of the called procedure     */

  call RoutineA
  call RoutineB
  call RoutineC
  call RoutineD

exit

/* ------------------------- sub routines --------------------------- */

RoutineA:
  call GetRoutineStatistics sigl
  say 'This is RoutineA'

  call RoutineB
  call RoutineC
return

RoutineB: PROCEDURE expose sigl
  call GetRoutineStatistics sigl
  say 'This is RoutineB'
return

RoutineC: PROCEDURE expose sigl
  call GetRoutineStatistics sigl
  say 'This is RoutineC'

  call RoutineB
return

RoutineD: PROCEDURE expose sigl
  call GetRoutineStatistics sigl
  say 'This is RoutineD'

  call RoutineA
  call RoutineC
return

/* ------------------------------------------------------------------ */
/*-function: Get and print debugging information                      */
/*                                                                    */
/*-call:     call GetRoutineStatistics sigl {,donotprint}             */
/*                                                                    */
/* where:    sigl - the variable sigl                                 */
/*           donotprint - if this parameter exists with any value     */
/*                        there's nothing written to STDOUT           */
/*-returns:  0                                                        */
/*                                                                    */
/*-notes:    It is important that this procedure is called in the     */
/*           *FIRST* line after the procedure definition!             */
/*           It's also mandatory that the procedure MUST expose       */
/*           the variable SIGL if it is defined with the keyword      */
/*           PROCEDURE!                                               */
/*                                                                    */
/* example Usage:                                                     */
/*                                                                    */
/*    MySubRoutine:                                                   */
/*      call GetRoutineStatistics sigl                                */
/*                                                                    */
/* or                                                                 */
/*    MySubRoutine: PROCEDURE expose sigl                             */
/*      call GetRoutineStatistics sigl                                */
/*                                                                    */
GetRoutineStatistics: PROCEDURE expose sigl
  parse arg debug.__lineCalledFrom
  debug.__FirstLineOfRoutine = sigl-1
  parse value sourceLine( sigl-1 ) with debug.__thisRoutine ':' .
  if arg( 2, 'o' ) = 1 then
  do
    call LineOut, '[+++DEBUG+++] ' ||  'Inside "' || debug.__thisRoutine || 
                  '" (Line ' || debug.__FirstLineOfRoutine || ')'
    call LineOut, '[+++DEBUG+++] ' ||  '  Called from line ' || 
                  debug.__lineCalledFrom || '.'
  end
return
</PRE>

==IPC and process synchronisation==
===Create a unique name===
There are 2 methods to create unique names for programs running at the same time in two or more sessions:

1. Using a directory name
<PRE>
/* example code to show how to use a directory name to get a unique   */
/* name                                                               */

  uniqueName = ""
  do i = 1 to 999 until rc = 0
    uniqueName = "C:\TEMP\unique." || i
                                /* try to create a directory          */
                                /* OS/2 checks that only ONE process  */
                                /* can create the directory!          */
    "@md " uniqueName "1>NUL 2>NUL"
  end /* do i = 1 to 999 */

  if rc == 0 then
    say "The unique name is" uniqueName
  else
    say "No unique name found!"

/* do something */
/* ... */
                                /* free the name                      */
  "@rd " uniqueName "1>NUL 2>NUL"
exit 0
</PRE>

2. Using the name of a QUEUE

<PRE> 
/* example code to show how to use a queue name to get a unique       */
/* name                                                               */

                                /* create a queue with a unique name  */
  uniqueName = rxqueue( "create" )

  say "The unique name is" uniqueName

/* do something */
/* ... */
                                /* free the name                      */
  call rxqueue "Delete", uniqueName
exit 0
</PRE>

[[Category:REXX Tips & Tricks]]