home *** CD-ROM | disk | FTP | other *** search
/ ftp.update.uu.se / ftp.update.uu.se.2014.03.zip / ftp.update.uu.se / pub / rainbow / msdos / decus / RB125 / makeabs.pas < prev    next >
Pascal/Delphi Source File  |  1995-06-04  |  6KB  |  299 lines
  1. (***********************************************************************
  2.  
  3. Name:        MakeAbs.Pas
  4. Version:    1.0
  5.  
  6.      This software has been placed into the public domain by Digital
  7.              Equipment Corporation.
  8.  
  9.  
  10. DISCLAIMER:
  11.  
  12. The information herein is subject to change without  notice  and  should
  13. not be construed as a commitment by Digital Equipment Corporation.
  14.  
  15. Digital Equipment Corporation assumes no responsibility for the  use  or
  16. reliability  of  this  software.   This  software  is  provided "as is,"
  17. without any warranty of any kind, express or implied.  Digital Equipment
  18. Corporation  will  not    be liable in any event for any damages including
  19. any loss of data, profit, or savings, claims against  the  user  by  any
  20. other  party,  or  any other incidental or consequential damages arising
  21. out of the use of, or inability to use, this software, even  if  Digital
  22. Equipment Corporation is advised of the possibility of such damage.
  23.  
  24. DEFECT REPORTING AND SUGGESTIONS:
  25.  
  26. Please send reports of defects or suggestions for  improvement    directly
  27. to the author:
  28.  
  29.     Brian Hetrick
  30.     Digital Equipment Corporation
  31.     110 Spit Brook Road  ZKO1-3/J10
  32.     Nashua NH  03062-2698
  33.  
  34. Do NOT file a Software Performance Report on  this  software,  call  the
  35. Telephone  Support  Center regarding this software, contact your Digital
  36. Field Office  regarding  this  software,  or  use  any    other  mechanism
  37. provided for Digital's supported and warranted software.
  38.  
  39.  
  40. FACILITY:
  41.  
  42.     TURBO Pascal MS-DOS support routines
  43.  
  44. ABSTRACT:
  45.  
  46.     Translates a relative  path  specification    into  an  absolute  path
  47.     specification  (one that does not depend upon current directories or
  48.     relative directory specifiers)
  49.  
  50. ENVIRONMENT:
  51.  
  52.     MS-DOS V2.0 or later, compiled with  Borland  International's  TURBO
  53.     Pascal V3.0 or later.
  54.  
  55. AUTHOR: Brian Hetrick, CREATION DATE: 1 December 1986.
  56.  
  57. MODIFIED BY:
  58.  
  59.     Brian Hetrick, 01-Dec-86: Version 1.0
  60.   000 - Original creation of module.
  61.  
  62. ***********************************************************************)
  63. {.PA}
  64. (*
  65.  *  INCLUDE FILES:
  66.  *)
  67.  
  68. (*
  69.  *  LABEL DECLARATIONS:
  70.  *)
  71.  
  72. (*
  73.  *  CONSTANT DECLARATIONS:
  74.  *)
  75.  
  76. (*
  77.  *  TYPE DECLARATIONS:
  78.  *)
  79.  
  80. TYPE
  81.  
  82.     MakeAbsPath = STRING [255];
  83.  
  84. (*
  85.  *  OWN STORAGE:
  86.  *)
  87.  
  88. (*
  89.  *  TABLE OF CONTENTS:
  90.  *)
  91. {.PA}
  92. PROCEDURE MakePathAbsolute
  93.    (VAR RelativePath : MakeAbsPath);
  94.  
  95. (***********************************************************************
  96.  
  97. FUNCTIONAL DESCRIPTION:
  98.  
  99.     Finds the absolute path specification  for    a  given  relative  path
  100.     specification.  In the absolute path specification, the drive letter
  101.     and a root-relative path specification name the file.  In a relative
  102.     path specification, the drive letter need not appear (it defaults to
  103.     the current drive), and the path specification may    be  relative  to
  104.     the current path on the drive.
  105.  
  106. FORMAL PARAMETERS:
  107.  
  108.     Path.mt.r - The possibly relative path specification which is set to
  109.     be the corresponding absolute path specification.
  110.  
  111. RETURN VALUE:
  112.  
  113.     None.
  114.  
  115. IMPLICIT INPUTS:
  116.  
  117.     None.
  118.  
  119. IMPLICIT OUTPUTS:
  120.  
  121.     None.
  122.  
  123. SIDE EFFECTS:
  124.  
  125.     May obtain the current directory on the current drive, or  the  cur-
  126.     rent  directory on some other drive.  For some reason, MS-DOS acces-
  127.     es the drive when the current directory is requested,  so  this  may
  128.     generate  an  MS-DOS  level  error if the drive does not exist or if
  129.     there is no volume in the drive.
  130.  
  131. ***********************************************************************)
  132.  
  133.     VAR
  134.  
  135.     AbsolutePath       : MakeAbsPath;
  136.     DriveIndex       : INTEGER;
  137.     LastDeletePosition : INTEGER;
  138.     ScanPtr        : INTEGER;
  139.     ThisChar       : CHAR;
  140.  
  141.     BEGIN
  142.  
  143.     (*
  144.      *    Get drive index and current directory for drive
  145.      *)
  146.  
  147.     IF (Length (RelativePath) >= 2) AND (RelativePath [2] = ':')
  148.     THEN
  149.     BEGIN
  150.  
  151.     DriveIndex := Ord (UpCase (RelativePath [1])) - 64;
  152.     Delete (RelativePath, 1, 2)
  153.  
  154.     END
  155.     ELSE
  156.  
  157.     DriveIndex := 0;
  158.  
  159.     GetDir (DriveIndex, AbsolutePath);
  160.  
  161.     (*
  162.      *    Construct the absolute path name
  163.      *)
  164.  
  165.     IF Length (RelativePath) > 0
  166.     THEN
  167.     BEGIN
  168.  
  169.     IF (RelativePath [1] = '/') OR (RelativePath [1] = '\')
  170.     THEN
  171.  
  172.         Delete (AbsolutePath, 3, Length (AbsolutePath) - 2)
  173.  
  174.     ELSE IF (AbsolutePath [Length (AbsolutePath)] <> '\') AND
  175.         (AbsolutePath [Length (AbsolutePath)] <> '/')
  176.     THEN
  177.  
  178.         Insert ('\', AbsolutePath, Length (AbsolutePath) + 1)
  179.  
  180.     END;
  181.  
  182.     Insert (RelativePath, AbsolutePath, Length (AbsolutePath) + 1);
  183.  
  184.     (*
  185.      *    Fix lowercase and directory separators
  186.      *)
  187.  
  188.     FOR ScanPtr := 1 TO Length (AbsolutePath)
  189.     DO
  190.     BEGIN
  191.  
  192.     ThisChar := UpCase (AbsolutePath [ScanPtr]);
  193.     IF ThisChar = '/'
  194.     THEN
  195.         ThisChar := '\';
  196.     AbsolutePath [ScanPtr] := ThisChar
  197.  
  198.     END;
  199.  
  200.     (*
  201.      *    Fix up '.' and '..' references
  202.      *)
  203.  
  204.     ScanPtr := 1;
  205.     WHILE ScanPtr <= Length (AbsolutePath)
  206.     DO
  207.     BEGIN
  208.  
  209.     IF AbsolutePath [ScanPtr] = '\'
  210.     THEN
  211.         BEGIN
  212.  
  213.         (*
  214.          *    Check next character for '.'
  215.          *)
  216.  
  217.         IF (Length (AbsolutePath) > ScanPtr) AND
  218.            (AbsolutePath [ScanPtr + 1] = '.')
  219.         THEN
  220.         BEGIN
  221.  
  222.         (*
  223.          *  Check next character also for '..'
  224.          *)
  225.  
  226.         IF (Length (AbsolutePath) > ScanPtr + 1) AND
  227.            (AbsolutePath [ScanPtr + 2] = '.')
  228.         THEN
  229.             BEGIN
  230.  
  231.             (*
  232.              *    Have reference to parent directory.  Delete both
  233.              *    '..' and previous directory
  234.              *)
  235.  
  236.             LastDeletePosition := ScanPtr + 2;
  237.             REPEAT
  238.             ScanPtr := ScanPtr - 1
  239.             UNTIL (AbsolutePath [ScanPtr] = '\') OR
  240.               (AbsolutePath [ScanPtr] = ':');
  241.  
  242.             IF AbsolutePath [ScanPtr] = ':'
  243.             THEN
  244.             ScanPtr := ScanPtr + 1
  245.  
  246.             END
  247.         ELSE
  248.  
  249.             (*
  250.              *    Have reference to current directory.  Delete '.'
  251.              *    only
  252.              *)
  253.  
  254.             LastDeletePosition := ScanPtr + 1;
  255.  
  256.         (*
  257.          *  Delete directory references
  258.          *)
  259.  
  260.         Delete (AbsolutePath, ScanPtr,
  261.             LastDeletePosition - ScanPtr + 1)
  262.  
  263.         END
  264.         ELSE
  265.  
  266.         (*
  267.          *  Next character is not '.'
  268.          *)
  269.  
  270.         ScanPtr := ScanPtr + 1
  271.  
  272.         END
  273.     ELSE
  274.  
  275.         (*
  276.          *    Current character is not '\'
  277.          *)
  278.  
  279.         ScanPtr := ScanPtr + 1
  280.  
  281.     END;
  282.  
  283.     (*
  284.      *    Specification of the root directory through .. may leave only
  285.      *    the drive letter and colon
  286.      *)
  287.  
  288.     IF Length (AbsolutePath) = 2
  289.     THEN
  290.     Insert ('\', AbsolutePath, 3);
  291.  
  292.     (*
  293.      *    Return the absolute path
  294.      *)
  295.  
  296.     RelativePath := AbsolutePath
  297.  
  298.     END;
  299.