10 REM > Database
   20 REM Simple database manager
   30 ON ERROR REPORT:PRINT" at line ";ERL:END
   40 REM *** Set up database parameters here ***
   50 field_no%=6:REM number of fields
   60 field_len%=30:REM length of fields
   70 REM *** field labels set in PROCset_labels at end of program
   80 REM *** End of parameter setup ***
   90 PROCinit
  100 ON ERROR PROCerror:END
  110 REM *** Main program loop ***
  120 REPEAT
  130   PROCoptions
  140   CASE char% OF
  150     WHEN ASC("1"):PROCcreate
  160     WHEN ASC("2"):PROCload
  170     WHEN ASC("3"):quit%=TRUE
  180   ENDCASE
  190   IF NOT quit% THEN
  200     record%=0
  210     REM *** Secondary program loop ***
  220     REPEAT
  230       IF EXT#file%=0 THEN
  240         PROCedit(0)
  250         ELSE
  260         PROCdisplay
  270         char%=FNmove_opts
  280         CASE char% OF
  290           WHEN 1:IF record%>0 record%-=1 ELSE VDU 7
  300           WHEN 2:IF (record%+1)*rec_len%<EXT#file% record%+=1 ELSE VDU 7
  310           WHEN 3:PROCedit(1)
  320           WHEN 4:record%=EXT#file% DIV rec_len%:PROCedit(0)
  330           WHEN 5:CLOSE#file%:file%=0
  340         ENDCASE
  350       ENDIF
  360     UNTIL char%=5:REM *** end of secondary program loop ***
  370   ENDIF
  380 UNTIL quit%:REM *** end of main program loop ***
  390 END
  400 :
  410 DEFPROCinit
  420 REM program initialisation
  430 DIM label$(field_no%),field$(field_no%)
  440 PROCset_labels
  450 MODE 27
  460 quit%=FALSE
  470 file%=0
  480 rec_len%=field_no%*field_len%
  490 ENDPROC
  500 :
  510 DEFPROCerror
  520 REM error handling after initialisation
  530 IF file%<>0 CLOSE#file%:REM close database file if open
  540 REPORT:PRINT" at line ";ERL
  550 ENDPROC
  560 :
  570 DEFPROCoptions
  580 REM displays list of options
  590 CLS
  600 PRINT TAB(20,20)"Key 1 to create a new database"
  610 PRINT TAB(20,22)"Key 2 to load a database file"
  620 PRINT TAB(20,24)"Key 3 to quit"
  630 REPEAT
  640   char%=GET
  650 UNTIL char%>=ASC("1") AND char%<=ASC("3")
  660 ENDPROC
  670 :
  680 DEFPROCcreate
  690 REM create new database file
  700 LOCAL fname$
  710 REPEAT
  720   CLS
  730   PRINT TAB(20,20)"Please enter a filename for your new database"
  740   INPUT TAB(20,22)fname$
  750   REM try to open file to see if it already exists
  760   file%=OPENIN(fname$):REM try to open file for read-only access
  770   IF file%<>0 THEN
  780     CLOSE#file%
  790     CLS
  800     PRINT TAB(20,20)"File "+fname$+" already exists"
  810     PRINT TAB(20,22)"Press any key"
  820     REPEAT UNTIL GET
  830   ENDIF
  840 UNTIL file%=0
  850 REM file does not already exist - create new file
  860 file%=OPENOUT(fname$)
  870 ENDPROC
  880 :
  890 DEFPROCload
  900 REM load existing database file
  910 LOCAL fname$
  920 REPEAT
  930   CLS
  940   PRINT TAB(20,20)"Please enter filename of existing database"
  950   INPUT TAB(20,22)fname$
  960   file%=OPENUP(fname$)
  970   REM check to see if file has been opened
  980   IF file%=0 THEN
  990     CLS
 1000     PRINT TAB(20,20)"File "+fname$+" cannot be opened"
 1010     PRINT TAB(20,22)"Press any key"
 1020     REPEAT UNTIL GET
 1030   ENDIF
 1040 UNTIL file%<>0
 1050 ENDPROC
 1060 :
 1070 DEFPROCedit(x%)
 1080 REM edit record
 1090 REM x% = 0 if creating new record, x% = 1 if editing existing record
 1100 LOCAL n%,char%
 1110 PROClabels
 1120 PROCstars
 1130 PRINT TAB(21,30)"Key Ctrl-A to store record"
 1140 PRINT TAB(21,31)"Key Ctrl-B to clear record"
 1150 PRINT TAB(21,32)"Key Ctrl-C to leave edit mode"
 1160 CASE x% OF
 1170   WHEN 0:PROCedit_clear
 1180   WHEN 1:
 1190   FOR n%=1 TO field_no%:PRINT TAB(25,n%+19)FNtrunc(n%):NEXT:REM display fields
 1200   VDU 31,25,20:REM move cursor to start of first field
 1210 ENDCASE
 1220 *FX4,1
 1230 REPEAT
 1240   char%=GET:REM get keypress
 1250   CASE char% OF
 1260     WHEN 8,136:PROCedit_left
 1270     WHEN 137:PROCedit_right
 1280     WHEN 13,138:PROCedit_down
 1290     WHEN 139:PROCedit_up
 1300     WHEN 1:VDU 7:PROCstore
 1310     WHEN 2:PROCedit_clear
 1320     WHEN 3:IF record%*rec_len%>=EXT#file% AND record%>0 record%-=1
 1330     OTHERWISE:PROCupdate(char%)
 1340   ENDCASE
 1350 UNTIL (char%=1 OR char%=3) AND EXT#file%>0
 1360 *FX4
 1370 ENDPROC
 1380 :
 1390 DEFPROCedit_right
 1400 REM move cursor right
 1410 IF POS<field_len%+24 VDU 9
 1420 ENDPROC
 1430 :
 1440 DEFPROCedit_left
 1450 REM move cursor left
 1460 IF POS>25 VDU 8
 1470 ENDPROC
 1480 :
 1490 DEFPROCedit_down
 1500 REM move cursor to start of next field down
 1510 IF VPOS<field_no%+19 VDU 31,25,VPOS+1
 1520 ENDPROC
 1530 :
 1540 DEFPROCedit_up
 1550 REM move cursor to start of next field up
 1560 IF VPOS>20 VDU 31,25,VPOS-1
 1570 ENDPROC
 1580 :
 1590 DEFPROCupdate(char%)
 1600 REM update character in field
 1610 IF char%>31 AND char% <127 THEN
 1620   MID$(field$(VPOS-19),POS-24,1)=CHR$(char%)
 1630   VDU char%
 1640   IF POS>field_len%+25 VDU 8
 1650 ENDIF
 1660 ENDPROC
 1670 :
 1680 DEFPROCstore
 1690 REM store record in file
 1700 LOCAL n%
 1710 PTR#file%=record%*rec_len%
 1720 FOR n%=1 TO field_no%
 1730   BPUT#file%,field$(n%);
 1740 NEXT
 1750 ENDPROC
 1760 :
 1770 DEFPROCedit_clear
 1780 REM fill all fields of records with spaces and show stars on screen
 1790 LOCAL n%
 1800 FOR n%=1 TO field_no%
 1810   field$(n%)=STRING$(field_len%," ")
 1820 NEXT
 1830 PROCstars
 1840 VDU 31,25,20:REM move cursor to start of first field
 1850 ENDPROC
 1860 :
 1870 DEFPROCdisplay
 1880 REM display contents of record and wait for keypress
 1890 LOCAL n%
 1900 PROClabels
 1910 PROCdisplay_bottom
 1920 PTR#file%=record%*rec_len%
 1930 FOR n%=1 TO field_no%
 1940   field$(n%)="":FOR I%=1 TO field_len%:field$(n%)+=CHR$(BGET#file%):NEXT
 1950   PRINT TAB(25,n%+19)field$(n%)
 1960 NEXT
 1970 ENDPROC
 1980 :
 1990 DEFPROClabels
 2000 REM Print record number and names of labels
 2010 LOCAL n%
 2020 CLS
 2030 PRINT"Record number ";record%+1
 2040 FOR n%=1 TO field_no%
 2050   PRINT TAB(24-LEN(label$(n%)),n%+19)label$(n%):REM print label, right-justified
 2060 NEXT
 2070 ENDPROC
 2080 :
 2090 DEFPROCstars
 2100 REM fill fields with stars
 2110 LOCAL n%
 2120 FOR n%=1 TO field_no%
 2130   PRINT TAB(25,n%+19)STRING$(field_len%,"*")
 2140 NEXT
 2150 ENDPROC
 2160 :
 2170 DEFFNmove_opts
 2180 REM waits for key 0 - 9 to be pressed and returns number
 2190 LOCAL char%
 2200 REPEAT
 2210   char%=GET
 2220 UNTIL char%>&2F AND char%<&3A
 2230 =char% AND &F
 2240 :
 2250 DEFPROCdisplay_bottom
 2260 REM displays database options
 2270 PRINT TAB(21,30)"Key 1 for previous record"
 2280 PRINT TAB(21,31)"Key 2 for next record"
 2290 PRINT TAB(21,33)"Key 3 to edit this record"
 2300 PRINT TAB(21,34)"Key 4 to add new record"
 2310 PRINT TAB(21,35)"Key 5 to close this database"
 2320 ENDPROC
 2330 :
 2340 DEFFNtrunc(n%)
 2350 REM returns contents of field with spaces at end removed
 2360 LOCAL a$
 2370 a$=field$(n%)
 2380 WHILE RIGHT$(a$)=" " a$=LEFT$(a$):ENDWHILE
 2390 =a$
 2400 :
 2410 DEFPROCset_labels
 2420 REM *** Define field label names here ***
 2430 label$(1)="Name:"
 2440 label$(2)="Address:"
 2450 label$(6)="Phone:"
 2460 ENDPROC
 2470 :