Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/XMOVE.ZIP/XMOVE.PAS

Pascal/Delphi Source File | 1989-08-27 | 6.6 KB | 240 lines

{$M 32864,0,655360}
Program XMOVE(input,output);

{
  This program was written by John Gatewood Ham 7/31/89 using
  Turbo Pascal 5.5.
  "Created using Turbo Pascal, Copyright (c) Borland International
  1987,1988."
}

uses dos;
const okletter:set of char = ['a'..'z','A'..'Z','0'..'9','?'];
type dirrec_pointer = ^dirrec;
     dirrec = record
                path:string;
                next:dirrec_pointer;
              end;

var name1,
    name2,
    parm1:string;
    original_dir:dirstr;
    original_name:namestr;
    original_extension:extstr;
    top:dirrec_pointer;

Procedure getlegal;
begin
  writeln('Created using Turbo Pascal, Copyright (c) Borland',
          ' International 1987,1988.');
end;

Procedure rename_a_file(oldname,newname:string;var errcode:integer);
var regs:registers;
begin
   oldname:=fexpand(oldname);
   newname:=fexpand(newname);
   oldname:=oldname+#0;
   newname:=newname+#0;
   regs.ah:=$56;
{must be var[1] because var[0] is length byte and we don't
 want that byte included in the file name}
   regs.ds:=seg(oldname[1]);
   regs.dx:=ofs(oldname[1]);
   regs.es:=seg(newname[1]);
   regs.di:=ofs(newname[1]);
   msdos(regs);
   if (regs.flags and fcarry) = 1 then
     begin
      case regs.ax of
        2 : writeln('File not found');
        3 : writeln('Path not found');
        5 : writeln('Access Denied; Target file exists');
      else
        writeln('error number ',regs.ax);
      end;
      errcode:=regs.ax;
     end
   else
     errcode:=0;
end;

procedure push(item:string);
var    newdragitem,dragitem,prevdragitem:dirrec_pointer;
begin
  if memavail <= sizeof(newdragitem) then
     begin
        writeln('Error: Out of Memory.  XMOVE Aborted.');
        halt;
     end;
  new(newdragitem);
  newdragitem^.path:=item;
  newdragitem^.next:=nil;
  dragitem:=top;
  prevdragitem:=nil;
  while dragitem <> nil do
    begin
      prevdragitem:=dragitem;
      dragitem:=dragitem^.next;
    end;
  if prevdragitem=nil then
      top:=newdragitem
  else
      prevdragitem^.next:=newdragitem;
end;

procedure makepath(pathname:string);
var q,res:integer;
begin
  pathname:=copy(pathname,1,length(pathname)-1);
  writeln('Creating path "',pathname,'"');
  {$i-}
  mkdir(pathname);
  {$i+}
  res:=ioresult;
  if res = 3 then
    {need to make this things parent}
    begin
      q:=length(pathname);
      while pathname[q] <> '\' do
        q:=q-1;
      makepath(copy(pathname,1,q));
      {$i-}
      mkdir(pathname);
      {$i+}
      res:=ioresult;
    end;
  if res <> 0 then
    writeln('ioresult="',res,'"');
  push(pathname);
end;

procedure searchdirectory(filename:string;
                          recurse:boolean);
var
  oldname,newname:string;
  nextdirectory:string;
  tempdirectory:string;
  currentdta   :searchrec;
  dir:dirstr;
  name:namestr;
  extension:extstr;
  searchspec:string;
  results:integer;

  function created_directory:boolean;
  var  skip:boolean;
       dragpointer:dirrec_pointer;
  begin
    skip:=false;
    dragpointer:=top;
    repeat
      if dragpointer^.path=dir+currentdta.name then
            skip:=true;
      dragpointer:=dragpointer^.next;
    until skip or (dragpointer=nil);
    created_directory:=skip;
  end;

begin
  filename:=fexpand(filename);
  fsplit(filename,dir,name,extension);
  searchspec:=name+extension;
  if recurse then
  begin
      tempdirectory:=dir + '*.*';
      findfirst(tempdirectory,anyfile,currentdta);
      while (doserror <> 2) and (doserror <> 18) do
        begin
          if ( ( (currentdta.attr and Directory) = Directory )
          and (currentdta.name[1] <> '.'))
          then
            begin
              if not created_directory then
                begin
                  filename:=dir+currentdta.name+'\'+searchspec;
                  searchdirectory(filename,
                                 recurse);
                end;
            end;
          findnext(currentdta);
        end;
  end;

  tempdirectory:=dir+searchspec;
  findfirst(tempdirectory,anyfile,currentdta);

   while (doserror = 0) do
    begin
      if (not ( (currentdta.attr and Directory) = Directory )) and
         (currentdta.name[1] <> '.') then
       begin
         oldname:=dir+currentdta.name;
         newname:=name2+copy(dir,length(original_dir)+1,length(dir)-
                  length(original_dir)+1)+currentdta.name;
         writeln('Renaming "',oldname,'" --> "',newname,'"');
         rename_a_file(oldname,newname,results);
         if results = 3 then
         {make the path}
           begin
             makepath(name2+copy(dir,length(original_dir)+1,length(dir)-
                      length(original_dir)+1));
             rename_a_file(oldname,newname,results);
             if results <> 0 then
                begin
                   writeln('Fatal Error: Abort....');
                   halt;
                end;
           end;
       end;
      findnext(currentdta);
    end;
 end;

begin
  top:=nil;
  getlegal;
  if paramcount < 2 then
     begin
       writeln('XMOVE Utility by John Gatewood Ham');
       writeln('Usage is:');
       writeln('         --Source--             --Target--');
       writeln('XMOVE [drive:][path\]filespecs [drive:]path [/S]');
       writeln('XMOVE will move all files matching filespecs from the source');
       writeln('directory to the target directory on a drive, creating the');
       writeln('Target directory if necessary.  The /S switch will cause the');
       writeln('Program to recur through subdirectorys.  Both Source and');
       writeln('Target must be on the same drive.');
       halt;
     end;
   name1:=paramstr(1);
   name2:=paramstr(2);
   if name2[length(name2)] <> '\' then
      name2:=name2+'\';
   name1:=fexpand(name1);
   fsplit(name1,
          original_dir,
          original_name,
          original_extension);
   name2:=fexpand(name2);
   push(name2); { if name2 does not exist it will get pushed again, but
                  that doesn't hurt anything and you could check for
                  duplicates in the push but I'm lazy }
   if name1[1] <> name2[1] then
      begin
        writeln('XMOVE can only move files from one place on a drive to');
        writeln('another.  Use DOS XCOPY to copy files to another drive.');
        halt;
      end;
   parm1:=paramstr(3);
   if paramcount = 3 then
      if (parm1 = '/s') or
         (parm1 = '/S') then
          searchdirectory(name1,true)
      else
          searchdirectory(name1,false)
   else
      searchdirectory(name1,false);
end.