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