Category : Dbase (Clipper, FoxBase, etc) Languages Source Code
Archive   : NAN0304.ZIP
Filename : OPNMODES.PRG

 
Output of file : OPNMODES.PRG contained in archive : NAN0304.ZIP
* 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 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 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


  3 Responses to “Category : Dbase (Clipper, FoxBase, etc) Languages Source Code
Archive   : NAN0304.ZIP
Filename : OPNMODES.PRG

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/