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 / DGET.ASC < prev    next >
Text File  |  1986-12-07  |  5KB  |  174 lines
  1. 10 PRINT"This program must be entered via DIMS
  2. 20 STOP
  3. 1000 GOSUB 1890 'cs
  4. 1010 PRINT:PRINT TAB(29);"DGET 1.03 - October 30, 1983
  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.     C,N,NC,P6,P7,P8,P9,PI,S,T,T1,T2,C(),B$(),N$(),
  10.     SEARCHWORD$(),SEARCHFIELD(),SKIPWORD$(),LOOKFIELD(),DD$(),F$,FT$
  11. 1060 DIM DEST(30),USED(30),B1$(30):INREC=0
  12. 1070 '
  13.  
  14.                 OPEN SOURCE FILE
  15.  
  16. 1080 PRINT:INPUT"Name of source file";X$
  17. 1085 IF X$="" THEN 1820
  18. 1090 GOSUB 1920:F2$=Y$        'ucv
  19. 1100 IF MID$(F2$,2,1)=":" THEN 1120
  20. 1110 F2$=DD$(5)+F2$
  21. 1120 '
  22.  
  23.         TEST FOR EXISTENCE
  24.  
  25. 1130 ON ERROR GOTO 1160
  26. 1140    OPEN"I",3,F2$
  27. 1150    ON ERROR GOTO 0:GOTO 1200    'ok
  28. 1160 CLOSE 3
  29. 1170 IF ERR=53 THEN CLOSE 3:PRINT"File not found":RESUME 1070
  30. 1180 IF ERR=64 THEN PRINT"Bad file name, try again.":RESUME 1070
  31. 1190 ON ERROR GOTO 0
  32. 1200 '
  33.  
  34.                 ENTER SEQUENCE OF FIELDS
  35.  
  36. 1210 PRINT:PRINT"Here's the first line of "F2$".
  37. 1220 LINE INPUT#3,T$
  38. 1230 PRINT:PRINT T$
  39. 1240 CLOSE 3:OPEN"I",3,F2$
  40. 1250 PRINT:PRINT"Would you like to re-assign or skip fields? (n/y) ";:A$=INPUT$(1)
  41. 1252 IF A$="y" OR A$="Y" THEN 1260 ELSE FOR I=1 TO NC:DEST(I)=I:NEXT:NF=NC:PRINT:GOTO 1370
  42. 1260 PRINT:FOR I=1 TO NC:USED(I)=0:NEXT
  43. 1265 PRINT:INPUT"Number of fields in source file";NF:PRINT
  44. 1270 FOR I=1 TO NF
  45. 1280    PRINT"Destination field of field"I"(enter 0 to ignore)";:INPUT DEST(I)
  46. 1290    IF DEST(I)>NC THEN PRINT "This file only has"NC"fields.":GOTO 1280
  47. 1300    IF DEST(I)=0 THEN 1330
  48. 1310    IF USED(DEST(I)) THEN PRINT"Won't accept putting two fields into one.":GOTO 1280
  49. 1320    USED(DEST(I))=1
  50. 1330 NEXT
  51. 1340 PRINT:PRINT"Is this ok (y/n)? ";
  52. 1350 A$=INPUT$(1):PRINT A$
  53. 1360 IF A$<>"y" THEN GOTO 1200
  54. 1370 C=1:PRINT
  55. 1380 '
  56.  
  57.                 READ FILE
  58.  
  59. 1390 GOSUB 1840            'exit
  60. 1400 IF EOF(3) THEN 1790
  61. 1410 FOR I=1 TO NC:B$(I)="":NEXT:NR=NR+1
  62. 1420 LINE INPUT #3,T$
  63. 1430 INREC=INREC+1:GOSUB 2010         'parse into B1$ array j=fields found
  64. 1440 IF J<>NF THEN 1450 ELSE 1470
  65. 1450 IF P9 THEN PRINT CHR$(7);:LPRINT"Input file line"INREC"defective."
  66. 1460 PRINT"Input file line"INREC"defective."CHR$(7)
  67. 1470 FOR I=1 TO J 
  68. 1480    IF DEST(I) THEN 1490 ELSE 1520
  69. 1490    QUOTE=INSTR(T$,CHR$(126))
  70. 1500    IF QUOTE THEN MID$(T$,QUOTE,1)=CHR$(34):GOTO 1490
  71. 1510    B$(DEST(I))=B1$(I)
  72. 1520 NEXT
  73. 1530 '
  74.  
  75.                 ADD RECORD TO DIMS FILE
  76.  
  77. 1540 T$=""
  78. 1550 FOR J=1 TO NC
  79. 1560    IF LEN(T$)+LEN(B$(J))+1>FT*128
  80.     THEN 1570 ELSE 1590
  81. 1570    IF P9 THEN LPRINT "Input line"INREC"too long."
  82. 1580    PRINT"Input line"INREC"too long."CHR$(7)
  83. 1590    T$=T$+B$(J)+CHR$(126)
  84. 1600 NEXT
  85. 1610 N=N+1:PRINT N;T$;
  86. 1620 GOSUB 1650:PRINT"*";:GOSUB 1720:PRINT"!":C=1
  87. 1630 '
  88.  
  89.                 LOOP
  90.  
  91. 1640 GOTO 1380
  92. 1650 '
  93.  
  94.         (SUB) WRITE T$ AS RECORD # N
  95.  
  96. 1660 ON FT GOTO 1690,1670
  97. 1670 LSET R$=MID$(T$,129)    'latter half
  98. 1680 PUT #1,FT*N+2
  99. 1690 LSET R$=LEFT$(T$,128)    'first half
  100. 1700 PUT #1,FT*N+1
  101. 1710 RETURN
  102. 1720 '
  103.  
  104.         (SUB) WRITE T$ AS DUPE REC N
  105.  
  106. 1730 ON FT GOTO 1760,1740
  107. 1740 LSET S$=MID$(T$,129)
  108. 1750 PUT #2,FT*N+2
  109. 1760 LSET S$=LEFT$(T$,128)
  110. 1770 PUT #2,FT*N+1
  111. 1780 RETURN
  112. 1790 '
  113.  
  114.                 FINISH
  115.  
  116. 1800 CLOSE 3
  117. 1810 PRINT:PRINT NR"records added.
  118. 1820 PRINT:PRINT TAB(32)"Re-loading DEDIT.
  119. 1830 CHAIN DD$(1)+"DEDIT",1000
  120. 1840 '
  121.  
  122.  
  123.                 EXIT TEST (TERM DEP)
  124.  
  125. 1850 X$=INKEY$:X=0
  126. 1860 IF X$<>"" THEN X=ASC(X$)
  127. 1870 IF X=27 THEN CLOSE 3:GOTO 1790    'use ESC to escape listing
  128. 1880 RETURN
  129. 1890 '
  130.  
  131.  
  132.                 CLEAR SCREEN (TERM DEP)
  133.  
  134. 1900 PRINT CHR$(12);
  135. 1910 RETURN
  136. 1920 '
  137.  
  138.                 (SUB) UCV
  139.  
  140. 1930 Y$=""
  141. 1940 FOR K=1 TO LEN(X$)
  142. 1950    Y$=Y$+CHR$(32)
  143. 1960    X=ASC(MID$(X$,K,1))
  144. 1970    IF 96<X AND X<123 THEN MID$(Y$,K,1)=CHR$(X-32):GOTO 1990
  145. 1980    MID$(Y$,K,1)=MID$(X$,K,1)
  146. 1990 NEXT
  147. 2000 RETURN
  148. 2010 '
  149.  
  150.                 (SUB) PARSE ,-DELIM. RECORD T$ > B1$ ARRAY
  151.  
  152. 2020 '                returns J = number of fields found
  153. 2030 FOR J=1 TO NF:B1$(J)="":NEXT
  154. 2040 J=0
  155. 2050 ' process loop
  156. 2060    J=J+1:IF J=NF THEN 2170
  157. 2070    X=INSTR(T$,CHR$(44)) 'comma
  158. 2080    IF X=0 THEN 2170    'must be last field
  159. 2090    Y=INSTR(T$,CHR$(34))     'quote
  160. 2100    IF Y=0 OR ( Y<>0 AND X<Y ) THEN 2140 ELSE 2120 'comma before quote
  161. 2120    Z=INSTR(Y+1,T$,CHR$(34))
  162. 2130    X=INSTR(Z+1,T$,CHR$(44))'loc of next comma after close quote
  163. 2140    B1$(J)=MID$(T$,1,X-1):GOSUB 2200
  164. 2150 '        TRIM OFF USED PART
  165. 2160    T$=MID$(T$,X+1):GOTO 2050
  166. 2170 '        LAST FIELD
  167. 2180    B1$(J)=T$:GOSUB 2200
  168. 2190 RETURN
  169. 2200 '                (SUB) TRIM QUOTES OFF STRING
  170. 2210 IF LEFT$(B1$(J),1)=CHR$(34) THEN B1$(J)=RIGHT$(B1$(J),LEN(B1$(J))-1)
  171. 2220 IF RIGHT$(B1$(J),1)=CHR$(34) THEN B1$(J)=LEFT$(B1$(J),LEN(B1$(J))-1)
  172. 2230 RETURN
  173. N B1$(J)=RIGHT$(B1$(J),LEN(B1$(J))-1)
  174. 2220 IF RIGH