home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ftp.barnyard.co.uk
/
2015.02.ftp.barnyard.co.uk.tar
/
ftp.barnyard.co.uk
/
cpm
/
walnut-creek-CDROM
/
CPM
/
DATABASE
/
DIMS103.ARK
/
DGETP.ASC
< prev
next >
Wrap
Text File
|
1986-12-07
|
6KB
|
225 lines
10 PRINT"This program must be entered via DIMS
20 STOP
1000 GOSUB 2460 'cs
1010 PRINT:PRINT TAB(30);"DGET 1.04 - March 12, 1984
1020 ' by Dan Dugan -- public domain
1030 PRINT
1040 DEFINT A-Z
1050 COMMON I,J,K,X,Y,T$,R$,S$,T1$,SKIPPARSE,FT,SEARCH,
C,N,NC,P6,P7,P8,P9,PI,S,T,T1,T2,C(),B$(),N$(),
SEARCHWORD$(),SEARCHFIELD(),SKIPWORD$(),LOOKFIELD(),DD$(),F$,FT$
1060 DIM DEST(30),USED(30),B1$(30):INREC=0
1070 '
OPEN SOURCE FILE
1080 PRINT:INPUT"Name of source file";X$
1085 IF X$="" THEN 2390
1090 GOSUB 2490:F2$=Y$ 'ucv
1100 IF MID$(F2$,2,1)=":" THEN 1120
1110 F2$=DD$(5)+F2$
1120 '
TEST FOR EXISTENCE
1130 ON ERROR GOTO 1160
1140 OPEN"I",3,F2$
1150 ON ERROR GOTO 0:GOTO 1200 'ok
1160 CLOSE 3
1170 IF ERR=53 THEN CLOSE 3:PRINT"File not found":RESUME 1070
1180 IF ERR=64 THEN PRINT"Bad file name, try again.":RESUME 1070
1190 ON ERROR GOTO 0
1200 '
ENTER SEQUENCE OF FIELDS
1210 PRINT:PRINT"Here's the first line of "F2$".
1220 LINE INPUT#3,T$
1230 PRINT:PRINT T$
1240 CLOSE 3:OPEN"I",3,F2$
1250 PRINT:PRINT"Would you like to re-assign or skip fields? (n/y) ";:A$=INPUT$(1)
1252 IF A$="y" OR A$="Y" THEN 1260 ELSE FOR I=1 TO NC:DEST(I)=I:NEXT:NF=NC:PRINT:GOTO 1370
1260 PRINT:FOR I=1 TO NC:USED(I)=0:NEXT
1265 PRINT:INPUT"Number of fields in source file";NF:PRINT
1270 FOR I=1 TO NF
1280 PRINT"Destination field of field"I"(enter 0 to ignore)";:INPUT DEST(I)
1290 IF DEST(I)>NC THEN PRINT "This file only has"NC"fields.":GOTO 1280
1300 IF DEST(I)=0 THEN 1330
1310 IF USED(DEST(I)) THEN PRINT"Won't accept putting two fields into one.":GOTO 1280
1320 USED(DEST(I))=1
1330 NEXT
1340 PRINT:PRINT"Is this ok (y/n)? ";
1350 A$=INPUT$(1):PRINT A$
1360 IF A$<>"y" THEN GOTO 1200
1370 PRINT
1380 '
READ FILE
1390 GOSUB 2410 'exit
1400 IF EOF(3) THEN 2360
1410 FOR I=1 TO NC:B$(I)="":NEXT
1420 LINE INPUT #3,T$
1430 PRINT"+";:INREC=INREC+1:GOSUB 2580 'parse into B1$ array j=fields found
1440 IF J<>NF THEN 1450 ELSE 1470
1450 IF P9 THEN PRINT CHR$(7);:LPRINT:LPRINT"Input file line"INREC"defective."
1460 PRINT:PRINT"Input file line"INREC"defective."CHR$(7)
1470 FOR I=1 TO J
1480 IF DEST(I) THEN 1490 ELSE 1520
1490 QUOTE=INSTR(T$,CHR$(126))
1500 IF QUOTE THEN MID$(T$,QUOTE,1)=CHR$(34):GOTO 1490
1510 B$(DEST(I))=B1$(I)
1520 NEXT
1530 '
SEARCH
1540 IF SEARCH<>2 THEN 1590
1550 '
FIND
1560 IF INSTR(T$,SEARCHWORD$(0))=0 THEN 2200 'skip
1580 GOTO 1830
1590 '
FIELD SEARCH
1600 J=0 ' check for skips first
1610 IF SKIPWORD$(J)="" THEN 1700 ' try search then
1620 IF LOOKFIELD(J)<>0 THEN 1660 ' look in field
1630 IF INSTR(T1$,SKIPWORD$(J))<>0 THEN 2200 ' check whole rec - skip it
1640 J=J+1
1650 GOTO 1610
1660 IF INSTR(B$(LOOKFIELD(J)),SKIPWORD$(J))<>0 THEN 2200 ' field compare - skip
1670 IF B$(LOOKFIELD(J))="" AND SKIPWORD$(J)="_" THEN 2200 'blank
1680 J=J+1
1690 GOTO 1610
1700 IF SEARCHWORD$(0)="" THEN 1810 ' don't care so print it
1710 J=0: GOTO 1730 ' now search
1720 IF SEARCHWORD$(J)="" THEN 2200 ' hesitate no longer
1730 IF SEARCHFIELD(J)<>0 THEN 1770 ' field
1740 IF INSTR(T1$,SEARCHWORD$(J))<>0 THEN 1810 ' found it
1750 J=J+1
1760 GOTO 1720
1770 IF INSTR(B$(SEARCHFIELD(J)),SEARCHWORD$(J))<>0 THEN 1810
1780 IF B$(SEARCHFIELD(J))="" AND SEARCHWORD$(J)="_" THEN 1810
1790 J=J+1
1800 GOTO 1720
1810 '
GET READY TO DO IT
1830 '
PAUSE CONTROLS (TERM DEP IF UPPERCASE ONLY)
1840 GOSUB 2410 ' exit returns A
1850 IF A=122 THEN 2100 ' z means go on
1860 PRINT INREC;B$(1);TAB(30);"Ready (SPACE/z/ESC) > ";
1870 A$=INPUT$(1):A=ASC(A$):IF A=27 THEN 2360 ' finish
1880 PRINT A$;:IF A=13 OR A=32 OR A=122 THEN 2100
1890 GOSUB 2410 ' exit
2100 '
ADD RECORD TO DIMS FILE
2110 T$="":NR=NR+1
2120 FOR J=1 TO NC
2130 IF LEN(T$)+LEN(B$(J))+1>FT*128
THEN 2140 ELSE 2160
2140 IF P9 THEN LPRINT "Input line"INREC"too long."
2150 PRINT"Input line"INREC"too long."CHR$(7)
2160 T$=T$+B$(J)+CHR$(126)
2170 NEXT
2180 N=N+1:PRINT INREC"="N:PRINT T$;
2190 GOSUB 2220:PRINT" *";:GOSUB 2290:PRINT"!":C=1
2200 '
LOOP
2210 GOTO 1380
2220 '
(SUB) WRITE T$ AS RECORD # N
2230 ON FT GOTO 2260,2240
2240 LSET R$=MID$(T$,129) 'latter half
2250 PUT #1,FT*N+2
2260 LSET R$=LEFT$(T$,128) 'first half
2270 PUT #1,FT*N+1
2280 RETURN
2290 '
(SUB) WRITE T$ AS DUPE REC N
2300 ON FT GOTO 2330,2310
2310 LSET S$=MID$(T$,129)
2320 PUT #2,FT*N+2
2330 LSET S$=LEFT$(T$,128)
2340 PUT #2,FT*N+1
2350 RETURN
2360 '
FINISH
2370 CLOSE 3
2380 PRINT:PRINT NR"records added.
2390 PRINT:PRINT TAB(32)"Re-loading DEDIT.
2400 CHAIN DD$(1)+"DEDIT",1000
2410 '
EXIT TEST (TERM DEP)
2420 X$=INKEY$
2430 IF X$<>"" THEN A=ASC(X$)
2440 IF A=27 THEN CLOSE 3:GOTO 2360 'use ESC to escape listing
2450 RETURN
2460 '
CLEAR SCREEN (TERM DEP)
2470 PRINT CHR$(12);
2480 RETURN
2490 '
(SUB) UCV
2500 Y$=""
2510 FOR K=1 TO LEN(X$)
2520 Y$=Y$+CHR$(32)
2530 X=ASC(MID$(X$,K,1))
2540 IF 96<X AND X<123 THEN MID$(Y$,K,1)=CHR$(X-32):GOTO 2560
2550 MID$(Y$,K,1)=MID$(X$,K,1)
2560 NEXT
2570 RETURN
2580 '
(SUB) PARSE ,-DELIM. RECORD T$ > B1$ ARRAY
2590 ' returns J = number of fields found
2600 FOR J=1 TO NF:B1$(J)="":NEXT
2610 J=0
2620 ' process loop
2630 J=J+1:IF J=NF THEN 2730
2640 X=INSTR(T$,CHR$(44)) 'comma
2650 IF X=0 THEN 2730 'must be last field
2660 Y=INSTR(T$,CHR$(34)) 'quote
2670 IF Y=0 OR ( Y<>0 AND X<Y ) THEN 2700 ELSE 2680 'comma before quote
2680 Z=INSTR(Y+1,T$,CHR$(34))
2690 X=INSTR(Z+1,T$,CHR$(44))'loc of next comma after close quote
2700 B1$(J)=MID$(T$,1,X-1):GOSUB 2760
2710 ' TRIM OFF USED PART
2720 T$=MID$(T$,X+1):GOTO 2620
2730 ' LAST FIELD
2740 B1$(J)=T$:GOSUB 2760
2750 RETURN
2760 ' (SUB) TRIM QUOTES OFF STRING
2770 IF LEFT$(B1$(J),1)=CHR$(34) THEN B1$(J)=RIGHT$(B1$(J),LEN(B1$(J))-1)
2780 IF RIGHT$(B1$(J),1)=CHR$(34) THEN B1$(J)=LEFT$(B1$(J),LEN(B1$(J))-1)
2790 RETURN
N B1$(J)=RIGHT$(B1$(J),LEN(B1$(J)