home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PROGRAMS / UTILS / COMPRESS / LARC22.ZIP / LARC22.BAS next >
Encoding:
BASIC Source File  |  1989-03-08  |  13.9 KB  |  467 lines
  1. ' $title:'LARC - Attempt to make the Littlest ARC file' $pagesize:74 $linesize:132
  2. ' by Vernon D. Buerg, 2/21/87; 2/25/87 (1.1); 2/26/87 (1.2); 2/28/87 (1.3)
  3. '                     3/01/87 (1.4); 3/15/87 (1.5); 4/14/87 (1.6)
  4. '                     11/02/88 (1.8), 02/10/89 (1.9), 2/24/89 (2.1)
  5. '                     3/08/89 (2.2)
  6. '
  7. ' Purposes:
  8. '       - make the smallest ARC files possible
  9. '       - learn how the ADVBAS subroutines work
  10. '       - convert LBR to ARC files
  11. '       - evaluate compression efficiency of ARC utilities
  12. '       - convert ARC to ZIP files
  13. '
  14. '     If the processed ARC file is smaller, the original ARC file
  15. '     is replaced. The file's date and time are preserved.
  16. '
  17. '     If an LBR library file is encountered, it is ARC'ed. A copy
  18. '     of LUE.COM must be available in the DOS path. If you want to
  19. '     just convert LBR files, supply an input filespec of "*.LBR".
  20.  
  21. info.panel:
  22. data " LARC Version 2.2 by Vernon D. Buerg"
  23. data "
  24. data " Usage:
  25. data "       LARC d:[\path\]filespec  [d:\outpath]  [/A] [/P] [/C] [/L] [/R] [/Z]
  26. data "
  27. data "       The input file specification is required and specifies the
  28. data "       location of ARC files to be processed. The path name is optional.
  29. data "
  30. data "       You MUST not have the input dir as the current dir. The current
  31. data "       drive (and directory) is used for temporary work space. Each
  32. data "       ARC file is extracted to the current directory.
  33. data "
  34. data "       You must have ARCA, PKXUNPAK and any other associated programs
  35. data "       available from the DOS path depending on the options used.
  36. data "
  37. data " Options:
  38. data "       /A specifies that ARCA should be used.
  39. data "       /C specifies that QARC should be used.
  40. data "       /G specifies that PAK (GSARC) should be used.
  41. data "       /K specifies that PKARC should be used.
  42. data "       /P specifies that PKPAK should be used.
  43. data "       /Z specifies that PKZIP should be used
  44. data "
  45. data "       /L indicates that original LBR files be deleted after being converted.
  46. data "       /R specifies that a summary report is produced in the file LARC.RPT.
  47. data "9"
  48.  
  49. ' $page $subtitle:'--- Definitions'
  50. ' ==========================================================================
  51.  
  52.     defint a-z
  53.     maxfiles = 512
  54.     maxmethods = 6
  55.  
  56.     dim arc$(maxfiles)        ' filenames and stats for later
  57.     dim method$(maxmethods)         ' up to four methods used
  58.     dim savings(maxmethods)         ' total bytes saved per method
  59.     dim create$(maxmethods,2)       ' command line for create programs
  60.     dim sw(maxmethods)              ' indicates method is in use
  61.  
  62.     false = 0 : true = not false
  63.     cluster = 512                   ' target disk cluster size
  64.  
  65. extract.list:
  66.     data    ".ARC","pkunpak /r "
  67.     data    ".LBR","lue "
  68.     data    ".PAK","pak E /WA "
  69.     data    ".ZIP","pkunzip -o "
  70.     data    "9",""
  71.  
  72. create.list:
  73.     data    "A","arca "
  74.     data    "C","qarc -a "
  75.     data    "G","pak A "
  76.     data    "K","pkarc -a "
  77.     data    "P","pkpak -a "
  78.     data    "Z","pkzip -a -ea4 -eb4 "
  79.     data    "",""
  80.  
  81. ' $dynamic
  82.  
  83.     dim before!(maxfiles)        ' original file sizes
  84.     dim after!(maxfiles,maxmethods) ' sizes after each method
  85.     dim stamp(maxfiles,6)           ' file mo,dy,yr;hr,min,sec
  86.  
  87. ' $static
  88.  
  89.     def fneat$(x!)            ' neaten number displays
  90.        fneat$ = right$(space$(7)+str$(x!),7)
  91.     end def
  92.  
  93.     def fn ltrim$(x$)        ' trim leading blanks
  94.        while left$(x$,1)=" "
  95.          x$=mid$(x$,2)
  96.        wend
  97.        fn ltrim$ = x$
  98.     end def
  99.  
  100.     def fn rtrim$(x$)        ' trim trailing blanks
  101.        while right$(x$,1)=" "
  102.          x$=left$(x$,len(x$)-1)
  103.        wend
  104.        fn rtrim$ = x$
  105.     end def
  106.  
  107.     def fn trim$(x$)        ' trim left and right blanks
  108.        fn trim$ = fn rtrim$(fn ltrim$(x$))
  109.     end def
  110.  
  111.     def fn switch (x$)        ' process option switches
  112.        if instr(parm$,x$) _
  113.          then fn switch = true : _
  114.           mid$(parm$,instr(parm$,x$),2)="  " _
  115.          else fn switch = false
  116.     end def
  117.  
  118. ' $page $subtitle: 'Initialization'
  119. ' =============================================================================
  120.  
  121. initialize:
  122. 1000    on error goto err.traps
  123.     restore info.panel
  124.     read version$
  125.  
  126. build.cmds:                             ' build table of codes/commands
  127. 1100    restore create.list : cmds=0
  128.     do
  129.      read a$,c$
  130.      if a$<>"" then
  131.        cmds=cmds+1
  132.        create$(cmds,1)=a$
  133.        create$(cmds,2)=c$
  134.      end if
  135.     loop while a$<>""
  136.  
  137. 1200    call getdosv(majorv,minorv)     ' check dos version
  138.      if majorv<3 then print "Incorrect DOS version." : end
  139.  
  140.     parm$=command$                  ' command parameters and options
  141.     for i=1 to cmds
  142.      a$=create$(i,1) : p$="/"+a$    ' option letter
  143.      sw(i) = fn switch (p$)
  144.      if sw(i) then
  145.        methods=methods+1 : method$(methods)=a$
  146.        if a$="L" then swl=true      ' special for conversions
  147.        if a$="Z" then swz=true
  148.      end if
  149.     next
  150.  
  151.     swr = fn switch ("/R")          ' produce LARC.RPT
  152.     swl = fn switch ("/L")          ' delete converted LBR files
  153.  
  154.     if methods=0 then               ' default to just ARCA
  155.       sw(1) = true
  156.       methods=1
  157.       method$(1)="A"
  158.     end if
  159.  
  160. ' get input file d:\path\filename and output drive:\path
  161.  
  162.     if instr(parm$," ") _
  163.       then infile$ = fn trim$(left$(parm$,instr(parm$," ")-1)) : _
  164.            outpath$ = fn trim$(mid$(parm$,instr(parm$," ")+1)) _
  165.       else infile$ = fn trim$(parm$) : _
  166.            outpath$ = ""
  167.  
  168.     if infile$="" then
  169.       restore info.panel
  170.       while a$<>"9"
  171.        print a$
  172.        read a$
  173.       wend
  174.       end
  175.     end if
  176.  
  177.     if instr(infile$,".")=0 then infile$=infile$+".ARC"
  178.  
  179.     in.drive$=" "                   ' get drive letter of original files
  180.      if mid$(infile$,2,1) = ":" _
  181.        then in.drive$=left$(infile$,1) : _
  182.         infile$=mid$(infile$,3) _
  183.        else print "You must supply the input drive letter!" : _
  184.         end
  185.  
  186.     call drvspace (in.drive$,a,b,c) ' initial free space on source drive
  187.      before.space! = csng(a)*csng(b)*csng(c)
  188.      cluster = a * 512        ' target disk cluster size
  189.  
  190.     inpath$=""                      ' get input drive and path names
  191.     for i=len(infile$) to 1 step -1
  192.      if mid$(infile$,i,1)="\" _
  193.        then inpath$=left$(infile$,i) : _
  194.         infile$=mid$(infile$,i+1): _
  195.         exit for
  196.     next
  197.  
  198.     temp.drive$=" "                 ' make sure different drives\paths
  199.      call getdrv(temp.drive$)    ' for temp, input, and output
  200.  
  201.     temp.path$=string$(64,0)    ' temporary d:\path
  202.      call getsub (temp.path$,tlen)
  203.      temp.path$="\"+left$(temp.path$,tlen)+"\"
  204.      temp.file$=temp.drive$+":"+left$(temp.path$,len(temp.path$)-1)
  205.  
  206.     call findfirstf ("*.*"+chr$(0),0,retcd)   ' insure temp is empty
  207.  
  208.     if (temp.drive$ = in.drive$ and temp.path$=inpath$) _
  209.          or outpath$ = temp.file$ _
  210.          or retcd = 0 _
  211.            then
  212.       print "Input path:  ";in.drive$+":"+inpath$
  213.       print "Output path: ";outpath$
  214.       print "Temp path:   ";temp.file$
  215.       print
  216.       print "You must use a different d:\path for the original input files,"
  217.       print "and the output destination drive and path;  other than the"
  218.       print "current directory used for the temporary work files!"
  219.       print "The temporary directory must be empty."
  220.       end
  221.     end if
  222.  
  223. ' $page $subtitle: 'Mainline'
  224. ' =============================================================================
  225.  
  226. mainline:
  227. 2000    attr = 0 : retcd=0                      ' get first file name
  228.     arcname$=in.drive$+":"+inpath$+infile$  ' from original filespec
  229.  
  230.     call findfirstf (arcname$+chr$(0),attr,retcd)
  231.      if retcd then
  232.        print "No matching files found for ";arcname$
  233.        end
  234.      end if
  235.  
  236. ' Build table of files to process
  237.  
  238. get.file:                    ' extract next file name
  239.     infile$=space$(12)
  240.      call getnamef (infile$,flen)
  241.      if flen <0 _
  242.        then print "GETNAMEF logical error." : end _
  243.        else infile$=left$(infile$,flen)
  244.  
  245.      if numfiles < maxfiles _        ' save data for report
  246.        then numfiles=numfiles+1
  247.  
  248.      call getdatef(month,day,year)        ' preserve datestamp
  249.       stamp(numfiles,1)=month
  250.       stamp(numfiles,2)=day
  251.       stamp(numfiles,3)=year
  252.      call gettimef(hour,minute,second)
  253.       stamp(numfiles,4)=hour
  254.       stamp(numfiles,5)=minute
  255.       stamp(numfiles,6)=second
  256.  
  257.      call getsizef(lo,hi)            ' original file size
  258.       lo!=csng(lo)
  259.       if lo<0 then lo!=lo!+65536!
  260.       insize!=lo!+csng(hi)*65536!
  261.  
  262.      arc$(numfiles)=infile$
  263.      before!(numfiles)=insize!
  264.      for method=1 to methods
  265.       after!(numfiles,method)=insize!
  266.      next method
  267.  
  268.     call findnextf (retcd)            ' next file to process
  269.     if retcd=0 then goto get.file
  270.  
  271. ' $page $subtitle:'Invoke ARC processors for each archive file'
  272. ' ----------------------------------------------------------------
  273.  
  274. process:
  275. 100    for filenum=1 to numfiles
  276.      infile$=arc$(filenum)                  ' original file name
  277.      insize!=before!(filenum)        '  and file size
  278.      before!=insize!
  279.      arcname$=in.drive$+":"+inpath$+infile$    ' complete original filespec
  280.  
  281.      outfile$=infile$            ' form target file name
  282.      if instr(infile$,".LBR") _
  283.        then mid$(outfile$,instr(infile$,".LBR"),4)=".ARC"
  284.  
  285.  
  286. 120    method = 0                ' index for method used to ARC
  287.     if insize!<cluster then         ' skip small files?
  288.       for s=1 to methods
  289.        after!(filenum,s)=insize!
  290.       next
  291.       if outpath$ = "" _                    ' unless copying all ARC files
  292.         then print "Skipping small file: ";arcname$ : goto next.file
  293.     end if
  294.  
  295. 130     replaced=copies                         ' times file has been copied
  296.     restore extract.list                    ' determine extractor name
  297.     do
  298.      read a$,c$
  299.      if instr(arcname$,a$) then cmd$=c$+arcname$ : exit do
  300.     loop while a$<>"9"
  301.  
  302.     cls : color 15,0 : print cmd$ : color 7,0
  303.     shell cmd$
  304.  
  305. ' create new archive file
  306.  
  307.     for m=1 to cmds                         ' Use each program
  308.      if sw(m) then
  309.       a$=create$(m,1)                        ' method letter
  310.       select case a$
  311.        case "G" : mid$(outfile$,instr(outfile$,"."),4)=".PAK"
  312.        case "Z" : mid$(outfile$,instr(outfile$,"."),4)=".ZIP"
  313.        case else :mid$(outfile$,instr(outfile$,"."),4)=".ARC"
  314.       end select
  315.       cmd$=create$(m,2)+outfile$+" *.*"      ' command line
  316.       cls : color 15,0 : print cmd$ : color 7,0
  317.       shell cmd$
  318.       gosub evaluate
  319.      end if
  320.     next m
  321.  
  322.     if okay then kill "*.*"         ' rid extracted files
  323.  
  324.     if outpath$<>"" and _           ' insure new file is copied
  325.      (replaced=copies) _
  326.       then color 15,0 : shell "copy "+infile$+" "+outpath$ : color 7,0
  327.  
  328.     if replaced<>copies _        ' delete original LBR/ZIP file
  329.       and ( (swl and instr(infile$,".LBR")) _
  330.        or   (swz and instr(infile$,".ARC")) ) _
  331.       then kill arcname$
  332.  
  333. next.file:
  334.     next filenum
  335.  
  336. ' $page $subtitle: 'Display file statistics'
  337. ' =============================================================================
  338.  
  339. report:
  340. 200    if swr _
  341.       then rptname$="larc.rpt" _
  342.       else rptname$="scrn:"
  343.        open rptname$ for output as #1
  344.  
  345.     beep                    ' wake em up
  346.  
  347.     if okay =0 then                         ' something broke
  348.       print  'locate 23,1
  349.       print "Aborted due to Error (";err;"at";erl;") or ESC keyin!"
  350.       print
  351.       gosub newpage
  352.       else gosub heading
  353.     end if
  354.  
  355.     for i=1 to numfiles
  356.      if swr=0 and csrlin>22 then gosub newpage
  357.      print #1,arc$(i);tab(13); fneat$(before!(i));
  358.      for s=1 to methods
  359.       after=int( (after!(i,s)+cluster-1)/cluster)
  360.       before=int( (before!(i)+cluster-1)/cluster)
  361.       savings = after-before
  362.       savings(s)=savings(s)+savings
  363.       print #1,fneat$(after!(i,s));" ";fneat$(csng(savings)*cluster);
  364.      next s
  365.      print #1,
  366.     next
  367.  
  368.     if swr=0 and csrlin>12 then gosub newpage
  369.      print #1,copies;"file(s) replaced";    ' Sum of savings by method
  370.      print #1,tab(27);" ";
  371.     for s=1 to methods
  372.      print #1,fneat$(csng(savings(s))*cluster);"        ";
  373.     next
  374.     print #1,
  375.  
  376.     call drvspace (in.drive$,a,b,c)     ' get disk space saving
  377.      after.space! = csng(a)*csng(b)*csng(c)
  378.  
  379.      print #1,
  380.      print #1," Free disk space: "
  381.      print #1,"           before ";
  382.      print #1,using "##,###,###";before.space!
  383.      print #1,"           after  ";
  384.      print #1,using "##,###,###";after.space!
  385.      print #1,"           saved  ";after.space! - before.space!;"bytes"
  386.  
  387.     close #1                ' all done
  388.  
  389.  
  390.     if swr then
  391.      open rptname$ for input as #1        ' display the report
  392.      while not eof (1)            '  in addition to writing it to
  393.       line input #1,a$            '   the file to LARC.RPT
  394.       print a$
  395.      wend
  396.      close #1
  397.     end if
  398.  
  399.     end
  400.  
  401. newpage:
  402.     line input "Press ENTER to continue:";a$
  403. heading:
  404.     cls                    ' pretty fancy, eh?
  405.     print #1,version$;" - Processing ";command$
  406.      print #1,
  407.      print #1,"Filename";tab(14);"before";
  408.      for s=1 to methods
  409.       print #1,"  after  ";method$(s);"-diff";
  410.      next
  411.     print #1,
  412.     locate ,1
  413.     return
  414.  
  415. ' $page $subtitle: 'Evaluate results of re-ARCing the files'
  416. ' ---------------------------------------------------------
  417.  
  418. evaluate:
  419.     okay = 0                ' indicates success or not
  420.     if inkey$ = chr$(27) then return report ' aborted by ESCape key
  421.     okay = 1
  422.     method = method + 1
  423.  
  424. 300    open outfile$ for input as #2        ' get new file size
  425.      outsize!=lof(2)
  426.      close #2
  427.  
  428. 310    after!(filenum,method)=outsize!
  429.  
  430.     'after=int( (outsize!+cluster-1)/cluster) ' compute clusters saved
  431.     'before=int( (before!+cluster-1)/cluster)
  432.     savings! = outsize! - before!          ' bytes (was clusters) saved
  433.  
  434. 400     if savings! <0 or outpath$<>"" or swz or swl then
  435.  
  436.      call setftd(outfile$+chr$(0),stamp(filenum,1),stamp(filenum,2), _
  437.              stamp(filenum,3),stamp(filenum,4),stamp(filenum,5), _
  438.              stamp(filenum,6) )     ' preserve date stamp
  439.  
  440.      if outpath$="" _               ' overlay original or to another subdir
  441.        then cmd$= "copy "+outfile$+" "+in.drive$+":"+inpath$+outfile$ _
  442.        else cmd$= "copy "+outfile$+" "+outpath$
  443.  
  444.      color 15,0 : print cmd$ : color 7,0
  445.      shell cmd$
  446.      before!=outsize!        ' new original file size
  447.      copies=copies+1
  448.     end if
  449.  
  450. 410     kill outfile$                   ' rid the temporary ARC file
  451. copy.done:
  452.     return
  453.  
  454. copy.failed:
  455.     okay = 0
  456.     return report 'next.file                ' file not found, not created, etc.
  457.  
  458. err.traps:
  459.     if erl=100 then print arcname$;" not found"
  460.     if erl=410 then resume copy.done    ' short file only copied
  461.     if erl=300 then
  462.       print "Copy failed! Not enough disk space." : beep
  463.       resume copy.failed      ' no ARC created
  464.     end if
  465.     print "Error";err;"at line";erl
  466.     end
  467.