home *** CD-ROM | disk | FTP | other *** search
/ Frostbyte's 1980s DOS Shareware Collection / floppyshareware.zip / floppyshareware / DPSX / TOOL-PAS.ZIP / CP.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-08-12  |  9.6 KB  |  406 lines
  1.  
  2. (*
  3.  * cp - unix like file copy
  4.  *
  5.  * shs 8/5/85
  6.  * version 2, shs 5/14/86
  7.  * version 3, shs 8/10/87
  8.  * version 4, shs 7/13/89
  9.  *
  10.  * Copyright (C) 1987, 1989 Samuel H. Smith, 8/5/85 (rev. 13-Jul-89)
  11.  *
  12.  *
  13.  * Disclaimer
  14.  * ----------
  15.  *
  16.  * I cannot be responsible for any damages resulting from the use or mis-
  17.  * use of this program!
  18.  *
  19.  * If you have any questions, bugs, or suggestions, please contact me at
  20.  * The Tool Shop,  (602) 279-2673.
  21.  *
  22.  * Enjoy!     Samuel H. Smith
  23.  *
  24.  *
  25.  *)
  26.  
  27. {$v-,s-}
  28.  
  29. uses dos, mdosio, tools;
  30.  
  31. const
  32.    version = 'CP - Unix-like file copy (v4.0, 07-15-89)';
  33.  
  34.    buf_size =        $F000;
  35.    bufsiz:           word = buf_size;
  36.  
  37.    update_newer:     boolean = false;
  38.    replace_readonly: boolean = false;
  39.    require_existing: boolean = false;
  40.  
  41. type
  42.    anystring = string[80];
  43.  
  44. var
  45.    buf:      array[1..buf_size] of byte;
  46.    cur_dir:  anystring;
  47.  
  48.  
  49. (* -------------------------------------------------------- *)
  50. procedure translate(var str: anystring; old, new: char);
  51. var
  52.    i: integer;
  53. begin
  54.    for i := 1 to length(str) do
  55.       if str[i] = old then
  56.          str[i] := new
  57.       else
  58.          str[i] := upcase(str[i]);
  59. end;
  60.  
  61.  
  62. (* -------------------------------------------------------- *)
  63. procedure addslash(var name: anystring);
  64. begin
  65.    if (name[length(name)] <> '\') and (name[length(name)] <> ':') then
  66.    begin
  67.       inc(name[0]);
  68.       name[length(name)] := '\';
  69.    end;
  70. end;
  71.  
  72.  
  73. (* -------------------------------------------------------- *)
  74. procedure makepath(var name: anystring; dir: anystring);
  75. var
  76.    i:    integer;
  77.    rest: anystring;
  78.  
  79. begin
  80.  
  81. (* make sure device is specified in pathname *)
  82.    if name[1] = '\' then
  83.       name := copy(dir,1,2) + name
  84.    else
  85.  
  86. (* make sure pathname is absolute *)
  87.    if name[2] <> ':' then
  88.       name := dir + name;
  89.  
  90. (* remove references to current directory *)
  91.    i := pos('\.\',name);
  92.    while i > 0 do
  93.    begin
  94.       name := copy(name,1,i) + copy(name,i+3,length(name));
  95.       i := pos('\.\',name);
  96.    end;
  97.  
  98. (* remove references to parent directory *)
  99.    i := pos('\..\',name);
  100.    while i > 0 do
  101.    begin
  102.       rest := copy(name,i+4,length(name));
  103.       i := i - 1;
  104.  
  105.       while (name[i] <> '\') and (i > 2) do
  106.          i := i - 1;
  107.  
  108.       name := copy(name,1,i) + rest;
  109.  
  110.       i := pos('\..\',name);
  111.    end;
  112.  
  113. (* change absolute into relative if possible *)
  114. (*******
  115.    if copy(name,1,length(cur_dir)) = cur_dir then
  116.       name := copy(name,length(cur_dir)+1,length(name));
  117. ********)
  118.  
  119. end;
  120.  
  121.  
  122. (* -------------------------------------------------------- *)
  123. procedure copyfile(len: integer; inName, outName: anystring);
  124. var
  125.    infd:    dos_handle;
  126.    outfd:   dos_handle;
  127.    length:  longint;
  128.    total:   longint;
  129.    incnt:   word;
  130.    time:    word;
  131.    date:    word;
  132.    attr:    word;
  133.    otime:   word;
  134.    odate:   word;
  135.    oattr:   word;
  136.    Info:    SearchRec;
  137.    F:       file;
  138.  
  139. begin
  140.    translate(inName,'\','/');
  141.    stolower(inName);
  142.    translate(outName,'\','/');
  143.    stolower(outName);
  144.  
  145.    if inName = outName then
  146.    begin
  147.       write(^G'cp: Input and output names [',inName,'] must be different.');
  148.       exit;
  149.    end;
  150.  
  151.    infd := dos_open(inName, open_read);
  152.    dos_file_times(infd, time_get, time, date);
  153.    oattr := 0;
  154.  
  155.    if dos_exists(outName) then
  156.    begin
  157.       if update_newer then
  158.       begin
  159.          outfd := dos_open(outName, open_read);
  160.          if outfd <> dos_error then
  161.          begin
  162.             dos_file_times(outfd, time_get, otime, odate);
  163.             dos_close(outfd);
  164.  
  165.             if (date = odate) and (time = otime) then
  166.             begin
  167.                write(outName,' is up to date.');
  168.                dos_close(infd);
  169.                exit;
  170.             end;
  171.  
  172.             if (date < odate) or ((date = odate) and (time <= otime)) then
  173.             begin
  174.                write(outName,' is newer.');
  175.                dos_close(infd);
  176.                exit;
  177.             end;
  178.          end;
  179.       end;
  180.  
  181.       if replace_readonly then
  182.       begin
  183.          FindFirst(outName,AnyFile,Info);
  184.          oattr := Info.attr and (ReadOnly or Hidden);
  185.          if oattr <> 0 then
  186.          begin
  187.             assign(F,outName);
  188.             SetFAttr(F, 0);
  189.             if DosError <> 0 then
  190.             begin
  191.                write(^G'cp: Can''t clear attributes on [',outName,'].');
  192.                dos_close(infd);
  193.                exit;
  194.             end;
  195.          end;
  196.       end;
  197.    end
  198.    else
  199.  
  200.    if require_existing then
  201.    begin
  202.       write(outName,' does not exist.');
  203.       dos_close(infd);
  204.       exit;
  205.    end;
  206.  
  207.    dos_lseek(infd, 0, seek_end);
  208.    length := dos_tell;
  209.  
  210.    dos_lseek(infd, 0, seek_start);
  211.  
  212.    write(inName,'':12-len,' -> ', outName,' ','':12-len);
  213.  
  214.    outfd := dos_create(outName);
  215.    if outfd = dos_error then
  216.    begin
  217.       writeln;
  218.       writeln(^G'cp: Can''t create output file [',outName,'].');
  219.       halt(1);
  220.    end;
  221.  
  222.    total := 0;
  223.    repeat
  224.       incnt := dos_read(infd, buf, bufsiz);
  225.  
  226.       if incnt <> 0 then
  227.       begin
  228.          dos_write(outfd, buf, incnt);
  229.          total := total + longint(incnt);
  230.          write('.');
  231.       end;
  232.    until (incnt <> bufsiz) or (dos_write_err);
  233.  
  234.    dos_close(infd);
  235.  
  236.    dos_file_times(outfd, time_set, time, date);
  237.    dos_close(outfd);
  238.  
  239.    if dos_write_err then
  240.    begin
  241.       writeln;
  242.       write(^G'cp: I/O error!  Destination [',outName,'] deleted.');
  243.       dos_unlink(outName);
  244.       exit;
  245.    end;
  246.  
  247.    {restore original attributes if needed}
  248.    if oattr <> 0 then
  249.    begin
  250.       if (oattr and ReadOnly) <> 0 then write(' R/O');
  251.       if (oattr and Hidden)   <> 0 then write(' Hid');
  252.       assign(F,outName);
  253.       GetFAttr(F, attr);
  254.       SetFAttr(F, oattr or attr);
  255.       if DosError <> 0 then
  256.          write(^G'cp: Can''t set attributes on [',outName,'].');
  257.    end;
  258.  
  259. end;
  260.  
  261.  
  262. (* -------------------------------------------------------- *)
  263. procedure procfile(source:   anystring;
  264.                    dest:     anystring);
  265. var
  266.    outname:    anystring;
  267.    len:        integer;
  268.  
  269. begin
  270.    makepath(source,cur_dir);
  271.    outname := remove_path(source);
  272.    len := length(outname);
  273.  
  274.    makepath(outname,dest);
  275.  
  276.    copyfile(len, source, outname);
  277.    writeln;
  278. end;
  279.  
  280.  
  281. (* -------------------------------------------------------- *)
  282. procedure procparam(pattern: anystring;
  283.                     dest:    anystring);
  284. var
  285.    i:   integer;
  286.  
  287. begin
  288.    translate(pattern,'/','\');
  289.    translate(dest,'/','\');
  290.    if pattern[1] = '-' then exit;
  291.  
  292.    addslash(dest);
  293.  
  294.    makepath(pattern,cur_dir);
  295.  
  296.    getfiles(pattern,filetable,filecount);
  297.    for i := 1 to filecount do
  298.       procfile(filetable[i]^,dest);
  299. end;
  300.  
  301.  
  302. (* -------------------------------------------------------- *)
  303. procedure usage(why: string);
  304. begin
  305.    writeln(version);
  306.    writeln('Copyright (C) 1987, 1989 Samuel H. Smith; All rights reserved.');
  307.    writeln('Courtesy of:  S.H.Smith  and  The Tool Shop BBS,  (602) 279-2673.');
  308.    writeln;
  309.    writeln(^G'Error: ',why);
  310.    writeln;
  311.    writeln('Usage:');
  312.    writeln('  cp {OPTIONS} SOURCE DEST');
  313.    writeln('  cp SOURCE1 SOURCE2 ... SOURCEn DEST');
  314.    writeln('  cp SOURCE');
  315.    writeln;
  316.    writeln('Options:');
  317.    writeln('  -U updates destination only if source is newer');
  318.    writeln('  -E copy only if destination file already exists');
  319.    writeln('  -R allows read-only destination to be replaced');
  320.    writeln('  -2 reduces buffering to 2k blocks (-6 = 6k, -8 = 8k)');
  321.    writeln;
  322.    writeln('Examples:');
  323.    writeln('  cp a:*.arc             ;copies all .arc files into current dir');
  324.    writeln('  cp /pcb/main/*.* /pcb/gen/*.* d:/backup');
  325.    writeln('  cp *.exe c:\lib -eru   ;update newer existing read-only files');
  326.    halt(1);
  327. end;
  328.  
  329.  
  330. (* -------------------------------------------------------- *)
  331. var
  332.    i,j:     integer;
  333.    dest:    anystring;
  334.    par:     anystring;
  335.    first:   boolean;
  336.    Info:    SearchRec;
  337.  
  338. begin
  339.    SetIntVec($24,SaveInt24);    {restore normal critical error handler,
  340.                                  allows 'FATAL' to work, if present}
  341.  
  342.    if paramcount = 0 then
  343.       usage('Missing command parameters.');
  344.  
  345.    dest := '.';
  346.    first := true;
  347.  
  348.    for i := 1 to paramcount do
  349.    begin
  350.       par := paramstr(i);
  351.       translate(par,'/','\');
  352.  
  353.       if par[1] = '-' then
  354.       begin
  355.          for j := 2 to length(par) do
  356.          case upcase(par[j]) of
  357.             'U':  update_newer := true;
  358.             'R':  replace_readonly := true;
  359.             'E':  require_existing := true;
  360.             '2':  bufsiz := 4*512;  {1 cluster}
  361.             '6':  bufsiz := 9*512;  {1 track on 360k drive}
  362.             '8':  bufsiz := 12*512; {1 track on 1.2meg drive}
  363.             else  usage('Unknown option: '+par[j]);
  364.          end;
  365.       end
  366.       else
  367.  
  368.       if first then
  369.          first := false
  370.       else
  371.          dest := par;
  372.    end;
  373.  
  374.    getdir(0,cur_dir);
  375.    addslash(cur_dir);
  376.  
  377.    if (copy(dest,length(dest)-1,2) <> ':\') then
  378.    begin
  379.       addslash(dest);
  380.       dest := path_only(dest);
  381.       if dest = '' then
  382.          dest := '@:';
  383.       if (length(dest) = 2) and (dest[2] = ':') then
  384.       begin
  385.          getdir(ord(dest[1])-ord('@'),dest);
  386.          addslash(dest);
  387.       end;
  388.       makepath(dest,cur_dir);
  389.    end;
  390.  
  391.    if (copy(dest,length(dest)-1,2) <> ':\') and (dest[length(dest)] <> ':') then
  392.    begin
  393.       FindFirst(dest,AnyFile,Info);
  394.       if (DosError <> 0) or ((Info.Attr and Directory) = 0) then
  395.          usage('Not a device or directory: '+dest);
  396.    end;
  397.  
  398.  
  399.    for i := 1 to paramcount do
  400.       if paramstr(i) <> dest then
  401.          procparam(paramstr(i),dest);
  402.  
  403.    halt(0);
  404. end.
  405.  
  406.