home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / cpm / database / dims103.ark / DGETP.ASC < prev    next >
Encoding:
Text File  |  1986-12-07  |  5.9 KB  |  225 lines
  1. 10 PRINT"This program must be entered via DIMS
  2. 20 STOP
  3. 1000 GOSUB 2460 'cs
  4. 1010 PRINT:PRINT TAB(30);"DGET 1.04 - March 12, 1984
  5. 1020 ' by Dan Dugan -- public domain
  6. 1030 PRINT
  7. 1040 DEFINT A-Z
  8. 1050 COMMON I,J,K,X,Y,T$,R$,S$,T1$,SKIPPARSE,FT,SEARCH,
  9.  
  10.     C,N,NC,P6,P7,P8,P9,PI,S,T,T1,T2,C(),B$(),N$(),
  11.  
  12.     SEARCHWORD$(),SEARCHFIELD(),SKIPWORD$(),LOOKFIELD(),DD$(),F$,FT$
  13. 1060 DIM DEST(30),USED(30),B1$(30):INREC=0
  14. 1070 '
  15.  
  16.  
  17.                 OPEN SOURCE FILE
  18.  
  19.  
  20. 1080 PRINT:INPUT"Name of source file";X$
  21. 1085 IF X$="" THEN 2390
  22. 1090 GOSUB 2490:F2$=Y$        'ucv
  23. 1100 IF MID$(F2$,2,1)=":" THEN 1120
  24. 1110 F2$=DD$(5)+F2$
  25. 1120 '
  26.  
  27.  
  28.         TEST FOR EXISTENCE
  29.  
  30.  
  31. 1130 ON ERROR GOTO 1160
  32. 1140    OPEN"I",3,F2$
  33. 1150    ON ERROR GOTO 0:GOTO 1200    'ok
  34. 1160 CLOSE 3
  35. 1170 IF ERR=53 THEN CLOSE 3:PRINT"File not found":RESUME 1070
  36. 1180 IF ERR=64 THEN PRINT"Bad file name, try again.":RESUME 1070
  37. 1190 ON ERROR GOTO 0
  38. 1200 '
  39.  
  40.  
  41.                 ENTER SEQUENCE OF FIELDS
  42.  
  43.  
  44. 1210 PRINT:PRINT"Here's the first line of "F2$".
  45. 1220 LINE INPUT#3,T$
  46. 1230 PRINT:PRINT T$
  47. 1240 CLOSE 3:OPEN"I",3,F2$
  48. 1250 PRINT:PRINT"Would you like to re-assign or skip fields? (n/y) ";:A$=INPUT$(1)
  49. 1252 IF A$="y" OR A$="Y" THEN 1260 ELSE FOR I=1 TO NC:DEST(I)=I:NEXT:NF=NC:PRINT:GOTO 1370
  50. 1260 PRINT:FOR I=1 TO NC:USED(I)=0:NEXT
  51. 1265 PRINT:INPUT"Number of fields in source file";NF:PRINT
  52. 1270 FOR I=1 TO NF
  53. 1280    PRINT"Destination field of field"I"(enter 0 to ignore)";:INPUT DEST(I)
  54. 1290    IF DEST(I)>NC THEN PRINT "This file only has"NC"fields.":GOTO 1280
  55. 1300    IF DEST(I)=0 THEN 1330
  56. 1310    IF USED(DEST(I)) THEN PRINT"Won't accept putting two fields into one.":GOTO 1280
  57. 1320    USED(DEST(I))=1
  58. 1330 NEXT
  59. 1340 PRINT:PRINT"Is this ok (y/n)? ";
  60. 1350 A$=INPUT$(1):PRINT A$
  61. 1360 IF A$<>"y" THEN GOTO 1200
  62. 1370 PRINT
  63. 1380 '
  64.  
  65.  
  66.                 READ FILE
  67.  
  68.  
  69. 1390 GOSUB 2410            'exit
  70. 1400 IF EOF(3) THEN 2360
  71. 1410 FOR I=1 TO NC:B$(I)="":NEXT
  72. 1420 LINE INPUT #3,T$
  73. 1430 PRINT"+";:INREC=INREC+1:GOSUB 2580         'parse into B1$ array j=fields found
  74. 1440 IF J<>NF THEN 1450 ELSE 1470
  75. 1450 IF P9 THEN PRINT CHR$(7);:LPRINT:LPRINT"Input file line"INREC"defective."
  76. 1460 PRINT:PRINT"Input file line"INREC"defective."CHR$(7)
  77. 1470 FOR I=1 TO J 
  78. 1480    IF DEST(I) THEN 1490 ELSE 1520
  79. 1490    QUOTE=INSTR(T$,CHR$(126))
  80. 1500    IF QUOTE THEN MID$(T$,QUOTE,1)=CHR$(34):GOTO 1490
  81. 1510    B$(DEST(I))=B1$(I)
  82. 1520 NEXT
  83. 1530 '
  84.  
  85.  
  86.  
  87.                 SEARCH
  88.  
  89.  
  90. 1540 IF SEARCH<>2 THEN 1590
  91. 1550 '
  92.  
  93.  
  94.         FIND
  95.  
  96.  
  97. 1560 IF INSTR(T$,SEARCHWORD$(0))=0 THEN 2200    'skip
  98. 1580 GOTO 1830
  99. 1590 '
  100.  
  101.  
  102.         FIELD SEARCH
  103.  
  104.  
  105. 1600 J=0 '            check for skips first
  106. 1610 IF SKIPWORD$(J)="" THEN 1700 ' try search then
  107. 1620 IF LOOKFIELD(J)<>0 THEN 1660 ' look in field
  108. 1630 IF INSTR(T1$,SKIPWORD$(J))<>0 THEN 2200 ' check whole rec - skip it
  109. 1640 J=J+1
  110. 1650 GOTO 1610
  111. 1660 IF INSTR(B$(LOOKFIELD(J)),SKIPWORD$(J))<>0 THEN 2200 ' field compare - skip
  112. 1670 IF B$(LOOKFIELD(J))="" AND SKIPWORD$(J)="_" THEN 2200    'blank
  113. 1680 J=J+1
  114. 1690 GOTO 1610
  115. 1700 IF SEARCHWORD$(0)="" THEN 1810 ' don't care so print it
  116. 1710 J=0: GOTO 1730 '        now search
  117. 1720 IF SEARCHWORD$(J)="" THEN 2200 ' hesitate no longer
  118. 1730 IF SEARCHFIELD(J)<>0 THEN 1770 ' field
  119. 1740 IF INSTR(T1$,SEARCHWORD$(J))<>0 THEN 1810 ' found it
  120. 1750 J=J+1
  121. 1760 GOTO 1720
  122. 1770 IF INSTR(B$(SEARCHFIELD(J)),SEARCHWORD$(J))<>0 THEN 1810
  123. 1780 IF B$(SEARCHFIELD(J))="" AND SEARCHWORD$(J)="_" THEN 1810
  124. 1790 J=J+1
  125. 1800 GOTO 1720
  126. 1810 '
  127.  
  128.  
  129.         GET READY TO DO IT
  130.  
  131.  
  132. 1830 '
  133.  
  134.  
  135.  
  136.                 PAUSE CONTROLS (TERM DEP IF UPPERCASE ONLY)
  137.  
  138.  
  139. 1840 GOSUB 2410            ' exit returns A
  140. 1850 IF A=122 THEN 2100        ' z means go on
  141. 1860 PRINT INREC;B$(1);TAB(30);"Ready (SPACE/z/ESC) > ";
  142. 1870 A$=INPUT$(1):A=ASC(A$):IF A=27 THEN 2360    ' finish
  143. 1880 PRINT A$;:IF A=13 OR A=32 OR A=122 THEN 2100
  144. 1890 GOSUB 2410            ' exit
  145. 2100 '
  146.  
  147.  
  148.                 ADD RECORD TO DIMS FILE
  149.  
  150.  
  151. 2110 T$="":NR=NR+1
  152. 2120 FOR J=1 TO NC
  153. 2130    IF LEN(T$)+LEN(B$(J))+1>FT*128
  154.  
  155.     THEN 2140 ELSE 2160
  156. 2140    IF P9 THEN LPRINT "Input line"INREC"too long."
  157. 2150    PRINT"Input line"INREC"too long."CHR$(7)
  158. 2160    T$=T$+B$(J)+CHR$(126)
  159. 2170 NEXT
  160. 2180 N=N+1:PRINT INREC"="N:PRINT T$;
  161. 2190 GOSUB 2220:PRINT" *";:GOSUB 2290:PRINT"!":C=1
  162. 2200 '
  163.  
  164.  
  165.                 LOOP
  166.  
  167.  
  168. 2210 GOTO 1380
  169. 2220 '
  170.  
  171.  
  172.         (SUB) WRITE T$ AS RECORD # N
  173.  
  174.  
  175. 2230 ON FT GOTO 2260,2240
  176. 2240 LSET R$=MID$(T$,129)    'latter half
  177. 2250 PUT #1,FT*N+2
  178. 2260 LSET R$=LEFT$(T$,128)    'first half
  179. 2270 PUT #1,FT*N+1
  180. 2280 RETURN
  181. 2290 '
  182.  
  183.  
  184.         (SUB) WRITE T$ AS DUPE REC N
  185.  
  186.  
  187. 2300 ON FT GOTO 2330,2310
  188. 2310 LSET S$=MID$(T$,129)
  189. 2320 PUT #2,FT*N+2
  190. 2330 LSET S$=LEFT$(T$,128)
  191. 2340 PUT #2,FT*N+1
  192. 2350 RETURN
  193. 2360 '
  194.  
  195.  
  196.                 FINISH
  197.  
  198.  
  199. 2370 CLOSE 3
  200. 2380 PRINT:PRINT NR"records added.
  201. 2390 PRINT:PRINT TAB(32)"Re-loading DEDIT.
  202. 2400 CHAIN DD$(1)+"DEDIT",1000
  203. 2410 '
  204.  
  205.  
  206.  
  207.                 EXIT TEST (TERM DEP)
  208.  
  209.  
  210. 2420 X$=INKEY$
  211. 2430 IF X$<>"" THEN A=ASC(X$)
  212. 2440 IF A=27 THEN CLOSE 3:GOTO 2360    'use ESC to escape listing
  213. 2450 RETURN
  214. 2460 '
  215.  
  216.  
  217.  
  218.                 CLEAR SCREEN (TERM DEP)
  219.  
  220.  
  221. 2470 PRINT CHR$(12);
  222. 2480 RETURN
  223. 2490 '
  224.  
  225.  
  226.                 (SUB) UCV
  227.  
  228.  
  229. 2500 Y$=""
  230. 2510 FOR K=1 TO LEN(X$)
  231. 2520    Y$=Y$+CHR$(32)
  232. 2530    X=ASC(MID$(X$,K,1))
  233. 2540    IF 96<X AND X<123 THEN MID$(Y$,K,1)=CHR$(X-32):GOTO 2560
  234. 2550    MID$(Y$,K,1)=MID$(X$,K,1)
  235. 2560 NEXT
  236. 2570 RETURN
  237. 2580 '
  238.  
  239.  
  240.                 (SUB) PARSE ,-DELIM. RECORD T$ > B1$ ARRAY
  241.  
  242.  
  243. 2590 '                returns J = number of fields found
  244. 2600 FOR J=1 TO NF:B1$(J)="":NEXT
  245. 2610 J=0
  246. 2620 ' process loop
  247. 2630    J=J+1:IF J=NF THEN 2730
  248. 2640    X=INSTR(T$,CHR$(44)) 'comma
  249. 2650    IF X=0 THEN 2730    'must be last field
  250. 2660    Y=INSTR(T$,CHR$(34))     'quote
  251. 2670    IF Y=0 OR ( Y<>0 AND X<Y ) THEN 2700 ELSE 2680 'comma before quote
  252. 2680    Z=INSTR(Y+1,T$,CHR$(34))
  253. 2690    X=INSTR(Z+1,T$,CHR$(44))'loc of next comma after close quote
  254. 2700    B1$(J)=MID$(T$,1,X-1):GOSUB 2760
  255. 2710 '        TRIM OFF USED PART
  256. 2720    T$=MID$(T$,X+1):GOTO 2620
  257. 2730 '        LAST FIELD
  258. 2740    B1$(J)=T$:GOSUB 2760
  259. 2750 RETURN
  260. 2760 '                (SUB) TRIM QUOTES OFF STRING
  261. 2770 IF LEFT$(B1$(J),1)=CHR$(34) THEN B1$(J)=RIGHT$(B1$(J),LEN(B1$(J))-1)
  262. 2780 IF RIGHT$(B1$(J),1)=CHR$(34) THEN B1$(J)=LEFT$(B1$(J),LEN(B1$(J))-1)
  263. 2790 RETURN
  264. N B1$(J)=RIGHT$(B1$(J),LEN(B1$(J)