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

 
Output of file : ASR.PRG contained in archive : NN0305.ZIP
* Program: ASR.prg
* Author: David Morgan
* Version: Clipper Summer '87
* Note(s): Array Save and Restore user-defined
* functions.
*
* Copyright (c) 1989 Nantucket Corp.

CLEAR
DECLARE the_arrays[3]
DECLARE current_events[5], literature[4]
DECLARE math[6]
the_arrays[1] = 'current_events'
the_arrays[2] = 'literature'
the_arrays[3] = 'math'
current_events[1] = 'Seoul'
current_events[2] = .F.
current_events[3] = ctod('11/08/88')
current_events[5] = 'World Series'
literature[1] = 'Because I do not hope to'+;
' turn again '+ ;
'Consequently I rejoice,' +;
' having to construct'+ ;
' something Upon which to' +;
' rejoice.'
literature[3] = 'As for man, his days are' + ;
' as grass: as a flower of'+ ;
' the field, so he' + ;
' flourisheth. For the' + ;
' wind passeth over it, and'+;
' it is gone' + ;
' and the place thereof' + ;
' shall know it no more.'
literature[4] = 'Nor I, nor any man that' + ;
' but man is, with nothing' +;
' shall be pleased till he '+;
'be eased with being nothing.'
math[1] = 3.14159
math[2] = 'trigonometry'
math[3] = 2.71828
math[4] = .T.
math[6] = 'approximation series'

Asave("the_arrays")
RELEASE current_events, literature, math
Arestore("the_arrays")


FUNCTION Asave
PARAMETERS filename
PRIVATE buffer, hndl, i, single_element,;
upper_bound
buffer = ''
BEGIN SEQUENCE
IF FILE(filename+'.ARR')
hndl = FOPEN(filename+'.ARR',2)
ELSE
hndl = FCREATE(filename+'.ARR',0)
ENDIF
is_f_ok()
FWRITE(hndl, buffer, 0)
is_f_ok()
single_element = &filename.[1]
IF TYPE(single_element) = 'A'
upper_bound = LEN(&filename.)
FOR i = 1 to upper_bound
single_element = &filename.[i]
IF TYPE(single_element) # 'A'
BREAK
ENDIF
DO save_1_array WITH single_element
NEXT
ELSE
DO save_1_array WITH filename
ENDIF
FCLOSE(hndl)
RETURN .T.
END SEQUENCE
FCLOSE(hndl)
ERASE (filename+'.ARR')
RETURN .F.


PROCEDURE save_1_array
PARAMETERS array
PRIVATE i, numstr, element, length, record
length = LEN(&array.)
record = 'A' + SUBSTR(array+SPACE(10),1,10) +;
STR(length,4,0)
FWRITE(hndl, record)
FOR i = 1 TO length
record = TYPE('&array.[i]')
element = IIF(record#'U', &array.[i], '')
DO CASE
CASE record = 'C'
record = record +STR(LEN(element),5,0)+;
element
CASE record = 'N'
numstr = LTRIM(TRIM(STR(element)))
record = record + I2BIN(LEN(numstr)) + ;
numstr
CASE record = 'L'
record = record + IIF(element, 'T', 'F')
CASE record = 'D'
record = record + DTOC(element)
END
FWRITE(hndl,record)
is_f_ok()
NEXT
RETURN


FUNCTION Arestore
PARAMETERS filename
PRIVATE hndl
BEGIN SEQUENCE
hndl = FOPEN(filename+'.ARR',0)
is_f_ok()
DO WHILE FREADSTR(hndl,1)= 'A'
DO rest_1_array
ENDDO
FCLOSE(hndl)
RETURN .T.
END SEQUENCE
FCLOSE(hndl)
RETURN .F.


PROCEDURE rest_1_array
PRIVATE aname, arecord, element, length, ;
no_elements, typ
arecord = FREADSTR(hndl,14)
is_f_ok()
aname = TRIM(SUBSTR(arecord,1,10))
no_elements = VAL(SUBSTR(arecord,11,4))
RELEASE &aname.
PUBLIC &aname.[no_elements]
FOR element = 1 TO no_elements
typ = FREADSTR(hndl,1)
is_f_ok()
DO CASE
CASE typ = 'C'
length = VAL(FREADSTR(hndl,5))
is_f_ok()
&aname.[element] = FREADSTR(hndl,length)
CASE typ = 'N'
length = BIN2I(FREADSTR(hndl,2))
is_f_ok()
&aname.[element] = VAL(FREADSTR(hndl,;
length))
CASE typ = 'L'
length = 1
&aname.[element] = (FREADSTR(hndl,;
length) = 'T')
CASE typ = 'D'
length = 8
&aname.[element] = CTOD(FREADSTR(hndl,;
length))
CASE typ = 'U'
OTHERWISE
RELEASE &aname.
BREAK
END
is_f_ok()
NEXT
RETURN


FUNCTION is_f_ok
IF FERROR() > 0
BREAK
ENDIF
RETURN ''


  3 Responses to “Category : Dbase (Clipper, FoxBase, etc) Languages Source Code
Archive   : NN0305.ZIP
Filename : ASR.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/