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