Mega CD-ROM 1/megacd_rom_1.zip/megacd_rom_1/CLIPPER/NANNWS34.ZIP/OPNMODES.PRG

Text File | 1989-01-01 | 6KB | 208 lines

* Program: OpnModes.prg
* Author:  David Morgan
* Version: Clipper Summer '87
*
* Copyright (c) 1988 Nantucket Corp.

CLEAR
SET WRAP ON

DECLARE inheritance[2], sharing[5], access[3]
inheritance[1] = 'inherited'
inheritance[2] = 'private'
sharing[1]     = 'compatibility'
sharing[2]     = 'deny read/write'
sharing[3]     = 'deny write'
sharing[4]     = 'deny read'
sharing[5]     = 'deny none'
access[1]      = 'read'
access[2]      = 'write'
access[3]      = 'read/write'

@ 0,6 SAY 'OPEN FILE TEST PROGRAM: test DOS open modes ' + ;
          'using Clipper FOPEN()'
@ 2,2 SAY CHR(179) + CHR(17) + REPLICATE(CHR(196), 10) + ;
   "Open Mode byte (DOS INT21 function 3Dh, 'Open File')" ;
   + REPLICATE(CHR(196), 10) + CHR(16) + CHR(179)
@ 3,2 SAY  'Inheritance      Sharing Mode' + ;
   '           Reserved        Access Mode'
@ 4,2 SAY  'bit field        bit field' + ;
   '              bit field       bit field'
@ 7,3 SAY '-                - - -                  0' + ;
          '               - - -'
@ 6,2 TO 8,4
@ 6,19 TO 8,21
@ 6,21 TO 8,23
@ 6,23 TO 8,25
@ 6,42 TO 8,44
@ 6,58 TO 8,60
@ 6,60 TO 8,62
@ 6,62 TO 8,64

box_menu(9, 2, inheritance, .F., .F.)
box_menu(9, 19, sharing, .F., .F.)
box_menu(9, 58, access, .F., .F.)

m_inheritance = box_menu(9, 2, inheritance, .F.) - 1
@ 7,3 SAY IIF(m_inheritance = 1, '1', '0')

m_sharing = box_menu(9, 19, sharing, .F.) - 1
@ 7,20 SAY IIF(m_sharing = 4, '1', '0')
@ 7,22 SAY IIF(m_sharing = 2 .OR. m_sharing = 3, '1', '0')
@ 7,24 SAY IIF(m_sharing = 1 .OR. m_sharing = 3, '1', '0')

m_reserved = 0

m_access = box_menu(9, 58, access, .F.) - 1
@ 7,59 SAY '0'
@ 7,61 SAY IIF(m_access = 2, '1', '0')
@ 7,63 SAY IIF(m_access = 1, '1', '0')

* Calculate open mode based on contribution
* from each subfield.
open_mode = m_inheritance * 128 + ;
            m_sharing     *  16 + ;
            m_reserved    *   8 + ;
            m_access      *   1
@ 7,70 SAY "= "+LTRIM(TRIM(STR(open_mode)))+;
   ' dec.'

file = choose_file(12, 31, '', '*')

hndl = FOPEN(file,open_mode)  && Try it and
                        ** see what happens!
@ 19,0 SAY 'Clipper command  FOPEN("'+ file +;
   '",'+ LTRIM(STR(open_mode)) + ')'
IF hndl = -1
  @ 19,COL() SAY ' <== Failed with DOS error ';
   + LTRIM(STR(FERROR())) + '.'
   IF FILE("DOSERRS.DBF")
      old_area = SELECT()
      SELECT 0
      USE DOSErrs
      GOTO FERROR()
      @ 20,0 SAY TRIM(err_msg)
      USE
      SELECT(old_area)
   END
ELSE
   @ 19,COL() SAY ' <== Succeeded, gaining '+;
      'DOS handle ' + LTRIM(STR(hndl)) + '.'
   SET COLOR TO i/n
   @ 21,15 SAY "Holding  " + file + "  open"+;
      " in mode you specified."
   SET COLOR TO w/n
   @ 22,15 SAY "Press any key to close file"+;
      " and quit. "
   SET CURSOR OFF
   INKEY(0)
   SET CURSOR ON
   @ 21,15 CLEAR TO 22,79
END
@ 23,0


* Function: Box_menu()
* Note(s):  Display item list in a box.
*           Optionally select among items
*           with MENU TO.
*
* box_menu(<expN1>,<expN2>,<array>,
*    [<expL1>,[<expL2>]])
*
* expN1,expN2 coordinates of box upper-left
*   corner.
* array contains choices (box height
*   accordingly, no scrolling).
* expL1 determines whether to restore
*   overwritten screen region.
* expL2 determines whether to perform MENU TO
*   selection.
*
FUNCTION box_menu
PARAMETERS top, left, promts, restscr, do_menu
do_menu = IIF(PCOUNT() < 5, .T., do_menu)
restscr = IIF(PCOUNT() < 4, .T., restscr)
PRIVATE choice, max_promt, row, winbuff
max_promt = LEN(promts[1])
FOR f = 2 TO LEN(promts)
   max_promt = MAX(LEN(promts[f]), max_promt)
NEXT
IF restscr
   winbuff = SAVESCREEN(top, left, top + ;
      LEN(promts) + 1, left + max_promt + 4)
END
@ top,left CLEAR TO top + LEN(promts) + 1,;
   left + max_promt + 4
@ top,left TO top + LEN(promts) + 1, left +;
   max_promt + 4
FOR row = top + 1 TO top + LEN(promts)
   IF do_menu
      @ row,left + 2 PROMPT promts[row-top]
   ELSE
      @ row,left + 2 SAY promts[row-top]
   END
NEXT
IF do_menu
   MENU TO choice
END
IF restscr
   RESTSCREEN(top, left, top+LEN(promts)+1,;
      left+max_promt+4, winbuff)
END
RETURN IIF(do_menu, choice, '')


* Function: Choose_file()
* Note(s):  Solicit a filename, either by
*           ACHOICE() or GET/READ, in a box.
*
* choose_file(<expN1>,<expN2>,[<expC1>,
*    [<expC2>]])
*
* expN1,expN2 coordinates of box upper-left
*   corner.
* expC1 prompt message, either SAYed if GET,
*   or below window if ACHOICE().  If none or
*   null, defaults to "Select a file."
* expC2 determines by presence or absence
*   whether to use ACHOICE() or GET.  If
*   present, limits field of ACHOICE()'s
*   candidate filenames to a filename
*   extension.  Pass "*" to get all files,
*   "" to get extensionless ones.
*
FUNCTION choose_file
PARAMETERS t, l, prompt, extension
PRIVATE file, filename, no_files, winbuff
prompt = IIF(PCOUNT() < 3, ;
   'Select a file', ;
   IIF('' = prompt, 'Select a file', prompt))
IF PCOUNT() >= 4
   no_files = ADIR("*.&extension.")
   IF no_files = 0
      RETURN ''
   END
   PRIVATE files[no_files]
   ADIR("*.&extension.", files)
   winbuff = SAVESCREEN( t, l, t+13,;
      l+MAX(14, LEN(prompt)))
   @ t,l CLEAR TO t + 13, l + 14
   @ t,l TO t + 10, l + 14
   @ t+12,l+1 SAY prompt
   file = ACHOICE(t+1,l+1, t+9, l+13, files)
   RESTSCREEN(t, l, t+13, ;
      l+MAX(14, LEN(prompt)), winbuff)
   RETURN IIF(file > 0, files[file], '')
ELSE
   filename = '            '
   winbuff = SAVESCREEN(t, l, t+2, l+30)
   @ t,l CLEAR TO t+2, l+30
   @ t,l TO t+2, l+30
   @ t+1,l+1 SAY prompt GET filename
   READ
   filename = ALLTRIM(filename)
   RESTSCREEN(t, l, t+2, l+30, winbuff)
   RETURN IIF(!EMPTY(filename), filename, '')
END