home *** CD-ROM | disk | FTP | other *** search
/ Frostbyte's 1980s DOS Shareware Collection / floppyshareware.zip / floppyshareware / USCX / TURBO-06.ZIP / CLIMB.PAS < prev    next >
Pascal/Delphi Source File  |  1985-02-23  |  22KB  |  558 lines
  1. {.PL66}
  2. { $B-,C-,I-,R-,V-,U-,K- }
  3. program climb; { Version V01.03 06/10/84 13:37 }
  4.  
  5. { This routine allows you to climb directory trees using TURBO Pascal.    }
  6. {                                                                         }
  7. {Syntax: CLIMB (-|?)UP    (d:)    Examples:   CLIMB UP A:                 }
  8. {                   DOWN                      CLIMB -DOWN C:              }
  9. {                   LEFT                      CLIMB LEFT                  }
  10. {                   RIGHT                     CLIMB -RIGHT                }
  11. {                                             CLIMB ?L                    }
  12. {                                             CLIMB -?RI                  }
  13. {                                                                         }
  14. { All paramters may be in upper or lower case and abbreviated.  If the    }
  15. { "do quietly" hyphen or the "query" question mark is specified, there    }
  16. { must be no interleaving space between it and the subcommand.            }
  17. {                                                                         }
  18. { When specified, the "do quietly" indicates that messages should be      }
  19. { suppressed.  This is useful in .BATs.                                   }
  20. {                                                                         }
  21. { When the "query" question mark is specified, instead of moving in the   }
  22. { indicated direction, the command simply indicates what action would be  }
  23. { taken.  It may be useful in .BAT programs to see if you can descend in  }
  24. { a given direction, but not have the path indicated.  CLIMB allows you to}
  25. { specify both "do quietly" and "query" in either order as long as they   }
  26. { are the first two characters.  It is also possible to specify -- or ??  }
  27. { in which case the second - or ? is ignored.                             }
  28. {                                                                         }
  29. { If a drive is not specified, the default drive is assumed.              }
  30. {                                                                         }
  31. {Up is obvious.  Down is the next lower path.  If there are multiple      }
  32. {lower paths, the first alphabetically is choosen.  Left goes up a path,  }
  33. {choses the next lower (alphabetically) path and descends to that.  Right }
  34. {is the opposite of right: it goes up a path, choses the next higher path }
  35. {alphabetically, and descends to that.                                    }
  36. {                                                                         }
  37. {If you can't climb in any direction, a nonzero return code is generated. }
  38. {                                                                         }
  39. { Return code   Meaning                                                   }
  40. { 0..........   Successful climb                                          }                                                                        }
  41. { 1-18 ......   DOS error codes, see DOS Manual page D-14                 }
  42. { 20.........   No paths in that direction.                               }
  43. { 255........   Invalid parameter                                         }
  44. {                                                                         }
  45. {Note that messages generated are written to the DOS standard output      }
  46. {device so you can pipe the messages to another file or device.           }
  47. {                                                                         }
  48. { The following is a batch file that illustrates how CLIMB will allow you }
  49. { to examine every directory on a disk. The name of this file is          }
  50. { typically called TOUR.BAT in that is allows you to tour the directories }
  51. { on a disk.                                                              }
  52. {                                                                         }
  53. {echo off                                                                 }
  54. {rem  This file "tours" all of the subdirectories using CLIMB             }
  55. {chdir \                                                                  }
  56. {:cmd_down                                                                }
  57. {REM ********** Insert commands below*******************                  }
  58. {REM ... First, display the directory ...                                 }
  59. {cd                                                                       }
  60. {REM ... Next, use your favorite directory command to list the contents   }
  61. {REM ... This is a good place to use the public domain SDIR command.      }
  62. {dir                                                                      }
  63. {REM ********** Insert commands above*******************                  }
  64. {climb -down                                                              }
  65. {if errorlevel 1 goto right                                               }
  66. {goto cmd_down                                                            }
  67. {:right                                                                   }
  68. {climb -right                                                             }
  69. {if errorlevel 1 goto up                                                  }
  70. {goto cmd_down                                                            }
  71. {:up                                                                      }
  72. {climb -up                                                                }
  73. {if errorlevel 1 goto exit                                                }
  74. {goto right                                                               }
  75. {exit:                                                                    }
  76. {Echo Tour is complete.                                                   }
  77. { .... End of TOUR.BAT ....                                               }
  78. {                                                                         }
  79. { If you are compiling this program using TURBO Pascal Version 2.0,       }
  80. { you can eliminate the annoying clear screen everytime this program      }
  81. { runs.  This procedure can be applied to all Turbo Pascal programs for   }
  82. { which you wish to eliminate the clear screen during initialization,     }
  83. { provided they have been compiled using version 2.0 of the Turbo Pascal  }
  84. { compiler...                                                             }
  85. {                                                                         }
  86. { DEBUG CLIMB.COM       <- Or any or compiled Turbo Pascal Program        }
  87. { -U 2FC                <- Make sure this is the right version            }
  88. { ssss:02FC INT 10      <- ssss will vary, first instruction listed       }
  89. {                          must be the INT 10.  Others will follow.       }
  90. { -A 2FC                                                                  }
  91. { ssss:02FC NOP         <- type in NOP                                    }
  92. { ssss:02FD NOP         <- twice                                          }
  93. { ssss:02FE             <- press enter                                    }
  94. { -W                    <- this replaces the program                      }
  95. { Writing hhhh bytes                                                      }
  96. { -Q                    <- quit debug                                     }
  97. {                                                                         }
  98. {;                                                                        }
  99. {; Copyright (c) 1984 Thomas J. Foth                                      }
  100. {; All Rights Reserved                                                    }
  101. {;                                                                        }
  102. {; Permission is granted to freely distribute this code, but not for      }
  103. {; profit and provided that the following address and disclaimer are      }
  104. {; included.                                                              }
  105. {;                                                                         }
  106. {; Portions of this program may be used freely, in other works, provided   }
  107. {; that credit to the author and this work appear with the portions used.  }
  108. {;                                                                         }
  109. {; The author's address:                                                   }
  110. {;                                                                         }
  111. {; Thomas J. Foth                                                          }
  112. {; 260 Sunset Ave.                                                         }
  113. {; Fairfield, CT 06880                                                     }
  114. {; (203) 334-6401                                                          }
  115. {;                                                                         }
  116. {; Disclaimer:                                                             }
  117. {;                                                                         }
  118. {; This program is provided "as-is" without warranty of any kind, either   }
  119. {; expressed or implied, including, but not limited to the implied         }
  120. {; warranties of merchantability and fitness for a particular purpose.     }
  121. {;                                                                         }
  122. const
  123.      readonly = $01;   { DOS 2.0 Attribute byte definitions }
  124.      hidden   = $02;
  125.      system   = $03;
  126.      vollabel = $08;
  127.      directory= $10;
  128.      archive  = $20;
  129.      mkdir    = $39;
  130.      rmdir    = $3A;
  131.      chdir    = $3B;
  132.      del      = $41;
  133.      chmod    = $43;
  134.      find_1st = $4E;
  135.      find_nxt = $4F;
  136.  
  137. type pathchar   = array[1..64] of char; { Used to communicate w/DOS }
  138.      asciiz     = array[1..255] of char;{ This array is an ASCIIZ string }
  139.      pathstring = string[255];          { For procedural calls }
  140.      anystring  = string[255];
  141.  
  142.      DTAptr     = ^DTA;
  143.  
  144.      DTA    = record                    { The Disk Transfer Area mapped out }
  145.                dos_usage: array[1..21] of char; { DOS internal usage        }
  146.                attribute: byte;         { File attribute, see constants     }
  147.                ftime    : integer;      { See page C-5 for explanation      }
  148.                fdate    : integer;      { Ditto                             }
  149.                fsize_lo : integer;      { See page C-6 for explanation      }
  150.                fsize_hi : integer;      { Ditto                             }
  151.                fname    : asciiz;       { filename.ext terminate by null byte}
  152.               end;
  153. var
  154.    i, rc           : integer;
  155.  
  156.    lookup_pattern,
  157.    current_path,
  158.    new_path,
  159.    low_path,
  160.    upper_path,
  161.    this_branch     : pathstring;
  162.  
  163.    parm            : string[11];
  164.    parm1_drive     : char absolute CSeg:$5C;
  165.    cparm1          : array[1..11] of char absolute CSeg:$5D;
  166.    drive           : byte absolute CSeg:$6C;
  167.    cparm2          : array[1..11] of char absolute CSeg:$6D;
  168.  
  169.    quietly,
  170.    query           : boolean;
  171.  
  172.    current_DTA     : DTAptr;
  173.  
  174. function asz2str(to_be_fixed: asciiz): pathstring;
  175. var
  176.    i               : integer;
  177.    tmp_str         : string[255];
  178. begin;
  179.  i:=1;
  180.  tmp_str:='';
  181.  while (to_be_fixed[i] <> chr(0)) and
  182.        (i<=255) do
  183.   begin;
  184.    tmp_str := tmp_str+to_be_fixed[i];
  185.    i:=i+1;
  186.   end;
  187.  asz2str := tmp_str;
  188. end;
  189.  
  190. procedure get_current_path(drive: byte;
  191.                            var the_path: pathstring;
  192.                            var rc:integer);
  193.  
  194. { Returns the current path in the form \path1\path2... for drive in
  195.   the path.  If drive = 0, use current drive.  rc is dos return code. }
  196. var
  197.    regs            : record
  198.                       ax,bx,cx,dx,bp,si,di,ds,es,flags: integer;
  199.                      end;
  200.    temp_chars      : asciiz;
  201.    i               : integer;
  202.  
  203. begin
  204.  regs.dx:=drive;
  205.  regs.ds:=seg(temp_chars);
  206.  regs.si:=ofs(temp_chars);
  207.  regs.ax:=$4700;              { Get the current path }
  208.  MsDos(regs);
  209.  
  210.  regs.flags := regs.flags and $0001;
  211.  if  regs.flags = 1 then
  212.  rc := regs.ax
  213.  else
  214.       begin;
  215.        the_path:='\'+asz2str(temp_chars);
  216.        rc := 0;
  217.        for i:=1 to length(the_path) do
  218.         if ord(copy(the_path,i,1)) > $60 then
  219.          the_path:=copy(the_path,1,i-1)+
  220.                    Upcase(copy(the_path,i,1))+
  221.                    copy(the_path,i+1,255);
  222.       end;
  223. end;
  224. function trunc_path(the_path: pathstring): pathstring;
  225. { This truncates the_path to an "upper" level path }
  226.  
  227. Var i              : integer;
  228.  
  229. begin;
  230.    i:=length(the_path);
  231.    while (i > 0) and (copy(the_path,i,1) <> '\') do i:=i-1;
  232.    i := i - 1;
  233.    if i <> 0 then
  234.     trunc_path := copy(the_path,1,i)
  235.     else trunc_path := '\';
  236. end;
  237. function this_path(the_path: pathstring): pathstring;
  238. { This truncates the_path to the current level path }
  239.  
  240. Var
  241.    i               : integer;
  242.  
  243. begin;
  244.    i:=length(the_path);
  245.    while (i > 0) and (copy(the_path,i,1) <> '\') do i:=i-1;
  246.     this_path := copy(the_path,i+1,255)
  247. end;
  248.  
  249. procedure fscall(func_code: integer;
  250.                  drive: byte;
  251.                  the_path: pathstring;
  252.                  mode: integer;
  253.                  var rc:integer);
  254.  
  255. { Perform a DOS2.0 file system call.  the_path must be in the
  256.   form \path1\path2... If drive is 0, the current drive is specified.
  257.   Specify drive=0 also allows the_path to take the form d:\path1\path2...}
  258. var
  259.    regs            : record
  260.                       ax,bx,cx,dx,bp,si,di,ds,es,flags: integer;
  261.                      end;
  262.    full_path       : pathstring;
  263.  
  264. begin
  265.  if drive = 0
  266.   then full_path := concat(the_path,chr(0))
  267.   else full_path := concat(CHR(64+drive),':',the_path,chr(0));
  268.  regs.ds:=seg(full_path);
  269.  regs.dx:=ofs(full_path)+1;
  270.  regs.cx:=mode;
  271.  regs.ax:=swap(func_code);
  272.  MsDos(regs);
  273.  
  274.  
  275.  regs.flags := regs.flags and $0001;
  276.  if  regs.flags = 1 then
  277.   rc := regs.ax
  278.  else rc := 0;
  279. end;
  280.  
  281. procedure stwrite(out_string:anystring);
  282.  
  283. {
  284. Allows you to write a string to the standard output device, thus
  285. allowing piping to take place
  286. }
  287. var
  288.    regs            : record
  289.                       ax,bx,cx,dx,bp,si,di,ds,es,flags: integer;
  290.                      end;
  291.  
  292. begin
  293.  regs.bx:=1;                  { Standard output device handle }
  294.  regs.cx:=length(out_string);
  295.  regs.ds:=seg(out_string);
  296.  regs.dx:=ofs(out_string)+1;
  297.  regs.ax:=$4000;
  298.  MsDos(regs);
  299.  
  300. end;
  301.  
  302. procedure stwriteln(out_string:anystring);
  303.  
  304. {
  305. Allows you to write a string to the standard output device, thus
  306. allowing piping to take place
  307. }
  308. begin
  309.  
  310.  stwrite(out_string+chr(13)+chr(10));
  311.  
  312. end;
  313.  
  314. function GetDTA: DTAptr;
  315. var
  316.    regs            : record
  317.                       ax,bx,cx,dx,bp,si,di,ds,es,flags: integer;
  318.                      end;
  319. begin;
  320.  
  321.  regs.ax:=$2F00;
  322.  MsDos(regs);                    {Get the current DTA}
  323.  GetDTA := Ptr(regs.es,regs.bx);
  324. end;
  325.  
  326. procedure leave(rc:integer);
  327. {Return to Dos with a return code }
  328. var
  329.    regs            : record
  330.                       ax,bx,cx,dx,bp,si,di,ds,es,flags: integer;
  331.                      end;
  332. begin;
  333.  
  334.  regs.ax:=$4C00+rc;
  335.  MsDos(regs);                    {Get the current DTA}
  336. end;
  337. procedure errmsg(rc:integer);
  338. {write the error message associated with an error number}
  339. var
  340.    str_rc          : string[255];
  341. begin;
  342. Case rc of
  343.  0: stwriteln('No error encountered');
  344.  1: stwriteln('Invalid function number');
  345.  2: stwriteln('File not found');
  346.  3: stwriteln('Path not found');
  347.  4: stwriteln('Too many files open');
  348.  5: stwriteln('Access denied');
  349.  6: stwriteln('Invalid handle');
  350.  7: stwriteln('Memory control block destroyed');
  351.  8: stwriteln('Insufficent memory');
  352.  9: stwriteln('Invalid memory block address');
  353. 10: stwriteln('Invalid environment');
  354. 11: stwriteln('Invalid format');
  355. 12: stwriteln('Invalid access code');
  356. 13: stwriteln('Invalid data');
  357. 15: stwriteln('Invalid drive specified');
  358. 16: stwriteln('Attempt to remove the current directory');
  359. 17: stwriteln('Not same device');
  360. 18: stwriteln('No more files');
  361. { Non DOS error codes unique to this program }
  362. 20: stwriteln('No more paths in that direction');
  363. 255: stwriteln('Invalid parameters');
  364. else str(rc,str_rc);
  365.      stwriteln('Unknown error code: '+str_rc);
  366. end;
  367. end;
  368.  
  369. {
  370.   Mainline begins here...
  371. }
  372.  
  373. Begin;
  374.  
  375.  if (parm1_drive <> chr(0)    ) or      { Can't specify drive in 1st parm }
  376.     (copy(cparm1,9,3) <> '   ') or      { nor an extension }
  377.     (cparm2 <> '           '  ) then    { nor a second filename }
  378.   begin;
  379.    errmsg(255);
  380.    leave(255);
  381.   end;
  382.  
  383.  quietly := false;
  384.  query   := false;
  385.  
  386.  parm:=''; { Convert PSP FCB1 to a string }
  387.  for i:=1 to 8 do if cparm1[i]<>' ' then parm:=concat(parm,cparm1[i]);
  388.  
  389.  for i:= 1 to 2 do { see if do quietly or query were specified }
  390.   begin;
  391.    if copy(parm,1,1)='-' then
  392.     begin;
  393.      quietly := true;
  394.      delete(parm,1,1);
  395.     end
  396.    else if copy(parm,1,1)='?' then
  397.     begin;
  398.      query := true;
  399.      delete(parm,1,1);
  400.     end;
  401.   end;
  402.  
  403.  if parm = '' then  { User doesn't understand the syntax, so they them }
  404.   begin;
  405.    stwriteln('Climb syntax:');
  406.    stwriteln(' ');
  407.    stwriteln('CLIMB (-|?)UP      (d:)');
  408.    stwriteln('CLIMB      DOWN');
  409.    stwriteln('CLIMB      LEFT');
  410.    stwriteln('CLIMB      RIGHT');
  411.    leave(255);
  412.  end;
  413.  
  414.  if Pos(parm,'UP') = 1 then parm:='UP'
  415.     else if Pos(parm,'DOWN') = 1 then parm := 'DOWN'
  416.     else if Pos(parm,'LEFT') = 1 then parm := 'LEFT'
  417.     else if Pos(parm,'RIGHT') = 1 then parm := 'RIGHT' else
  418.   begin;
  419.    if not quietly then errmsg(255); { Bad syntax, so abort }
  420.    leave(255);
  421.   end;
  422.  
  423.  get_current_path(drive,current_path,rc); { Where are we now? }
  424.  
  425.  if rc<>0 then                            { If we get an error here     }
  426.   begin;                                  { DOS is having REAL problems }
  427.    if not quietly then errmsg(rc);
  428.    leave(rc);
  429.   end;
  430.  
  431.   if (current_path = '\') and             { Only valid direction from   }
  432.     ((Pos(parm,'LEFT')=1) or              { root is down...             }
  433.      (Pos(parm,'UP')=1) or
  434.      (Pos(parm,'RIGHT')=1)) then
  435.    begin;
  436.     if not quietly then
  437.      begin;
  438.       errmsg(20);
  439.       stwrite('Current path: ');
  440.       if drive <> 0 then stwriteln(chr(64+drive)+':\')
  441.                   else stwriteln('\');
  442.      end;
  443.     leave(20);
  444.    end;
  445.  
  446.  if Pos(parm,'UP') = 1 then             { All going up is truncating the }
  447.    new_path := trunc_path(current_path) { lowest branch...               }
  448.   else
  449.   begin;
  450.  
  451.    low_path:='';
  452.    if Pos(parm,'LEFT') = 1 then
  453.    for i:=1 to 8 do low_path:=low_path+chr(0) { low_path is now at low value }
  454.    else for i:=1 to 8 do low_path:=low_path+chr(255); { or high value        }
  455.  
  456.    current_DTA:=GetDTA;                 { DOS leaves info in the DTA so we'd }
  457.                                         { better find it...                  }
  458.  
  459.    this_branch:=this_path(current_path);{ Isolate the name of this branch    }
  460.  
  461.    if Pos(parm,'DOWN') = 1 then
  462.     upper_path:=current_path            { look in this directory for DOWN    }
  463.     else upper_path:=trunc_path(current_path); { else, we have to look above }
  464.  
  465.    if upper_path <> '\' then            { Specify the search string          }
  466.     lookup_pattern:=upper_path+'\*.*'+chr(0)
  467.     else lookup_pattern:='\*.*'+chr(0);
  468.  
  469.    fscall(find_1st,drive,lookup_pattern,directory,rc); { Go a'hunting        }
  470.  
  471.    while rc = 0 do
  472.     begin;                               { Got one... (maybe)                }
  473.      if ((current_DTA^.attribute and directory) = directory) and
  474.          (current_DTA^.fname[1] <> '.') then  { Real directory?              }
  475.       begin;
  476.        if Pos(parm,'LEFT') = 1 then
  477.         begin;
  478.          if (asz2str(current_DTA^.fname) > low_path) and
  479.             (asz2str(current_DTA^.fname) < this_branch)
  480.           then low_path := asz2str(current_DTA^.fname);
  481.         end
  482.  {
  483.   If we are going left, we want a directory that is lower than the current
  484.   branch, yet higher than anything else...
  485.  }
  486.         else if Pos(parm,'RIGHT') = 1 then
  487.          begin;
  488.           if (asz2str(current_DTA^.fname) < low_path) and
  489.              (asz2str(current_DTA^.fname) > this_branch)
  490.            then low_path := asz2str(current_DTA^.fname);
  491.          end
  492.  {
  493.   Right directories, on the other hand, are higher than this directory, but
  494.   lower than everything else.
  495.  }
  496.          else
  497.           begin;
  498.             if (asz2str(current_DTA^.fname) < low_path)
  499.              then low_path := asz2str(current_DTA^.fname);
  500.           end;
  501.  {
  502.   And finally down directories are the lowest directory in the current
  503.   directory.
  504.  }
  505.       end;
  506.      fscall(find_nxt,drive,lookup_pattern,directory,rc); { Do it again... }
  507.     end;
  508.  
  509.   if (copy(low_path,1,1)=chr(255))
  510.      or (copy(low_path,1,1)=chr(0)) then  {If not set, we didn't find anything}
  511.    begin;                                 {that qualified                     }
  512.     if not quietly then
  513.      begin;
  514.       errmsg(20);
  515.       stwrite('Current path: ');
  516.       if drive=0 then stwriteln(current_path)
  517.                   else stwriteln(chr(64+drive)+':'+current_path);
  518.      end;
  519.     leave(20);
  520.    end;
  521.  
  522.   if upper_path <> '\' then               { Make the string for chdir }
  523.    new_path := upper_path+'\'+low_path
  524.   else new_path := '\'+low_path;
  525.  
  526.  end;
  527.  
  528.  if query then                            { If only a query, just show it }
  529.   begin;
  530.    if not quietly then
  531.     begin;
  532.      stwriteln('Current path: '+current_path);
  533.      stwrite('Next path '+parm+': ');
  534.      if drive = 0 then stwriteln(new_path)
  535.         else stwriteln(chr(64+drive)+':'+new_path);
  536.     end;
  537.    leave(0)
  538.   end
  539.  else
  540.   begin;
  541.  
  542.    fscall(chdir,drive,new_path,0,rc);     { else, chnage to it }
  543.  
  544.    if not quietly then
  545.     begin;
  546.      if  rc = 0  then
  547.       begin;
  548.        stwrite('Climbed '+parm+' to ');
  549.        if drive = 0 then stwriteln(new_path)
  550.         else stwriteln(chr(64+drive)+':'+new_path);
  551.       end
  552.       else errmsg(rc);
  553.     end;
  554.  
  555.    Leave(rc);
  556.   end;
  557. end.
  558.