home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / cpm / database / dims103.ark / DPUT.ASC < prev    next >
Encoding:
Text File  |  1986-12-07  |  4.3 KB  |  189 lines
  1. 10 PRINT"This program must be entered via DIMS.
  2. 20 STOP
  3. 1000 GOSUB 5840 'cs
  4. 1010 PRINT:PRINT TAB(25);"DPUT 1.03 - November 1, 1983
  5. 1015 ' by Dan Dugan -- public domain
  6. 1020 PRINT
  7. 1030 DEFINT A-Z
  8. 1040 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 '
  14.  
  15.  
  16.                 OPEN OUTPUT FILE
  17.  
  18.  
  19. 1070 PRINT:INPUT"Name of destination file";X$
  20. 1080 GOSUB 5950            'ucv
  21. 1085 F2$=Y$
  22. 1090 '        DISK NAME
  23.  
  24.  
  25. 1100 IF MID$(F2$,2,1)=":" THEN 1120
  26. 1110 F2$=DD$(5)+F2$
  27. 1120 '
  28.  
  29.         TEST FOR EXISTENCE
  30.  
  31.  
  32. 1130 ON ERROR GOTO 1160
  33. 1140    OPEN"I",3,F2$
  34. 1150    CLOSE 3:ON ERROR GOTO 0
  35. 1152    PRINT:PRINT F2$" exists already.  Use a different name.":GOTO 1060
  36. 1160 CLOSE 3
  37. 1170 IF ERR=53 THEN RESUME 1210    'not found
  38. 1180 IF ERR=61 THEN PRINT:PRINT"Sorry, disk full.":RESUME 5650 'exit
  39. 1190 IF ERR=64 THEN PRINT"Bad file name, try again.":RESUME 1060
  40. 1195 IF ERR=67 THEN PRINT:PRINT"Out of directory space.":RESUME 5650
  41. 1200 ON ERROR GOTO 0
  42. 1210 '
  43.  
  44.  
  45.         OPEN NEW FILE
  46.  
  47.  
  48. 1220 OPEN"O",3,F2$
  49. 1230 NR=0
  50. 5000 '
  51.  
  52.  
  53.  
  54.  
  55.                 RECORD WORK LOOP
  56.  
  57.  
  58. 5030 '
  59. 5040 FOR I=T1 TO T2 '        <==== FOR
  60. 5050 GOSUB 5870 ' get rec
  61. 5060 IF ASC(T$)=0 THEN PRINT"0";:GOTO 5630
  62. 5070 PRINT"+";
  63. 5075 GOSUB 7000            'strip linefeeds
  64. 5080 T1$=T$ ' save it
  65. 5090 IF SKIPPARSE=1 THEN 5110
  66. 5100 GOSUB 5700 ' parse record string
  67. 5110 IF SEARCH=0 THEN 5500
  68. 5120 '
  69.  
  70.  
  71.  
  72.                 SEARCH
  73.  
  74.  
  75. 5130 IF SEARCH<>2 THEN 5180
  76. 5135 '
  77.  
  78.  
  79.         FIND
  80.  
  81.  
  82. 5140 IF INSTR(T$,SEARCHWORD$(0))=0 THEN 5630
  83. 5160 GOSUB 5700 ' parse
  84. 5170 GOTO 5500
  85. 5180 '
  86.  
  87.  
  88.         FIELD SEARCH
  89.  
  90.  
  91. 5190 J=0 '            check for skips first
  92. 5200 IF SKIPWORD$(J)="" THEN 5280 ' try search then
  93. 5210 IF LOOKFIELD(J)<>0 THEN 5250 ' look in field
  94. 5220 IF INSTR(T1$,SKIPWORD$(J))<>0 THEN 5630 ' whole rec search - skip it
  95. 5230 J=J+1
  96. 5240 GOTO 5200
  97. 5250 IF INSTR(B$(LOOKFIELD(J)),SKIPWORD$(J))<>0 THEN 5630 ' field compare - skip
  98. 5255 IF B$(LOOKFIELD(J))="" AND SKIPWORD$(J)="_" THEN 5630
  99. 5260 J=J+1
  100. 5270 GOTO 5200
  101. 5280 IF SEARCHWORD$(0)="" THEN 5380 ' don't care so print it
  102. 5290 J=0: GOTO 5310 '        now search
  103. 5300 IF SEARCHWORD$(J)="" THEN 5630 ' hesitate no longer
  104. 5310 IF SEARCHFIELD(J)<>0 THEN 5350 ' field
  105. 5320 IF INSTR(T1$,SEARCHWORD$(J))<>0 THEN 5380 ' found it
  106. 5330 J=J+1
  107. 5340 GOTO 5300
  108. 5350 IF INSTR(B$(SEARCHFIELD(J)),SEARCHWORD$(J))<>0 THEN 5380
  109. 5355 IF B$(SEARCHFIELD(J))="" AND SEARCHWORD$(J)="_" THEN 5380
  110. 5360 J=J+1
  111. 5370 GOTO 5300
  112. 5380 '
  113.  
  114.  
  115.         GET READY TO DO IT
  116.  
  117.  
  118. 5390 IF SKIPPARSE=1 THEN GOSUB 5700 ' parse
  119. 5500 '
  120.  
  121.  
  122.                 DO WORK
  123.  
  124.  
  125. 5510 PRINT CHR$(40);I;CHR$(41)
  126. 5520 FOR J=1 TO NC
  127. 5530    IF C(J)=0 THEN 5610
  128. 5540 '        Substitute "~" for quote chars.
  129. 5550    QUOTE=INSTR(B$(J),CHR$(34))
  130. 5560    IF QUOTE THEN MID$(B$(J),QUOTE,1)=CHR$(126):GOTO 5550
  131. 5570 '        Put quotes around strings with commas in 'em
  132. 5580    IF INSTR(B$(J),CHR$(44)) THEN B$(J)=CHR$(34)+B$(J)+CHR$(34)
  133. 5590    IF J>1 THEN PRINT#3,CHR$(44);:PRINT CHR$(44);
  134. 5600    PRINT#3,B$(J);:PRINT B$(J);
  135. 5610 NEXT
  136. 5620 PRINT#3,:PRINT:NR=NR+1
  137. 5630    GOSUB 5790 ' check exit
  138. 5640 NEXT I '            END OF RECORD WORK LOOP
  139. 5650 '
  140.  
  141.  
  142.                 FINISH
  143.  
  144.  
  145. 5660 CLOSE 3
  146. 5670 PRINT:PRINT NR"records.
  147. 5680 PRINT:PRINT TAB(32)"Re-loading DEDIT.
  148. 5690 CHAIN DD$(1)+"DEDIT",1000
  149. 5700 '
  150.  
  151.  
  152.  
  153.  
  154.                 PARSE STRING
  155.  
  156.  
  157. 5710 K=0
  158. 5720 M=INSTR(T$,CHR$(126)) ' delimiter
  159. 5730 IF M=0 THEN RETURN
  160. 5740 K=K+1
  161. 5750 B$(K)=""
  162. 5760 B$(K)=MID$(T$,1,M-1)
  163. 5770 T$=MID$(T$,M+1)
  164. 5780 GOTO 5720
  165. 5790 '
  166.  
  167.  
  168.  
  169.                 (SUB) EXIT TEST
  170.  
  171.  
  172. 5800 X$=INKEY$:X=0
  173. 5810 IF X$<>"" THEN X=ASC(X$)
  174. 5820 IF X=27 THEN CLOSE 3:GOTO 5650    'use ESC to escape process
  175. 5830 RETURN
  176. 5840 '
  177.  
  178.  
  179.  
  180.                 (SUB) CLEAR SCREEN (TERM DEP)
  181.  
  182.  
  183. 5850 PRINT CHR$(12);
  184. 5860 RETURN
  185. 5870 '
  186.  
  187.  
  188.  
  189.                 (SUB) GET RECORD "I" IN T$
  190.  
  191.  
  192. 5880 T$="" ' necessary!
  193. 5890 ON FT GOTO 5920,5900
  194. 5900    GET#1,FT*I+2 ' latter half
  195. 5910    T$=LEFT$(R$,127)
  196. 5920    GET#1,FT*I+1 ' whole or first half
  197. 5930    T$=R$+T$
  198. 5940 RETURN
  199. 5950 '
  200.  
  201.  
  202.                 (SUB) UCV
  203.  
  204.  
  205. 5960 Y$=""
  206. 5970 FOR K=1 TO LEN(X$)
  207. 5980    Y$=Y$+CHR$(32)
  208. 5990    X=ASC(MID$(X$,K,1))
  209. 6000    IF 96<X AND X<123 THEN MID$(Y$,K,1)=CHR$(X-32):GOTO 6020
  210. 6010    MID$(Y$,K,1)=MID$(X$,K,1)
  211. 6020 NEXT
  212. 6030 RETURN
  213. 7000 '
  214.  
  215.  
  216.                 (SUB) STRIP ACCIDENTAL LINE-FEEDS
  217.  
  218.  
  219. 7010 LF=INSTR(T$,CHR$(10))
  220. 7020 IF LF THEN T$=LEFT$(T$,LF-1)+MID$(T$,LF+1):GOTO 7010
  221. 7030 RETURN
  222. P ACCIDENTAL LINE-FEEDS
  223.  
  224.  
  225. 7010 LF=INSTR(T$,CHR$(10))
  226.