home *** CD-ROM | disk | FTP | other *** search
/ Software of the Month Club 1995 December / SOFM_Dec1995.bin / pc / os2 / vpascal / source / rtl / windos.pas < prev    next >
Pascal/Delphi Source File  |  1995-10-31  |  16KB  |  455 lines
  1. {█▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀█}
  2. {█                                                       █}
  3. {█      Virtual Pascal Runtime Library.  Version 1.0.    █}
  4. {█      OS/2 Presentation Manager DOS interface unit     █}
  5. {█      ─────────────────────────────────────────────────█}
  6. {█      Copyright (C) 1995 B&M&T Corporation             █}
  7. {█      ─────────────────────────────────────────────────█}
  8. {█      Written by Vitaly Miryanov                       █}
  9. {█                                                       █}
  10. {▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀}
  11.  
  12. {$S-,R-,Q-,I-,Cdecl-,OrgName-,AlignRec-}
  13.  
  14. unit WinDos;
  15.  
  16. interface
  17.  
  18. uses Use32;
  19.  
  20. const
  21.  
  22. { Flags bit masks }
  23.  
  24.   fCarry     = $0001;
  25.   fParity    = $0004;
  26.   fAuxiliary = $0010;
  27.   fZero      = $0040;
  28.   fSign      = $0080;
  29.   fOverflow  = $0800;
  30.  
  31. { File mode magic numbers }
  32.  
  33.   fmClosed = $A55AD7B0;
  34.   fmInput  = $A55AD7B1;
  35.   fmOutput = $A55AD7B2;
  36.   fmInOut  = $A55AD7B3;
  37.  
  38. { File attribute constants }
  39.  
  40.   faReadOnly  = $01;
  41.   faHidden    = $02;
  42.   faSysFile   = $04;
  43.   faVolumeID  = $08;    { For compatibility only, OS/2 doesn't use this attribute }
  44.   faDirectory = $10;
  45.   faArchive   = $20;
  46.   faAnyFile   = $37;
  47.  
  48. { Maximum file name component string lengths }
  49.  
  50. const
  51.   fsPathName  = 259;
  52.   fsDirectory = 255;
  53.   fsFileName  = 255;
  54.   fsExtension = 255;
  55.  
  56. { FileSplit return flags }
  57.  
  58. const
  59.   fcExtension = $0001;
  60.   fcFileName  = $0002;
  61.   fcDirectory = $0004;
  62.   fcWildcards = $0008;
  63.  
  64. { Typed-file and untyped-file record }
  65.  
  66. type
  67.   TFileRec = record
  68.     Handle:   Longint;                  { File Handle                }
  69.     Mode:     Longint;                  { Current file mode          }
  70.     RecSize:  Longint;                  { I/O operation record size  }
  71.     Private:  array [1..28] of Byte;    { Reserved                   }
  72.     UserData: array [1..8] of Byte;     { User data area             }
  73.     Name:     array [0..259] of Char;   { File name (ASCIIZ)         }
  74.   end;
  75.  
  76. { Textfile record }
  77.  
  78. type
  79.   PTextBuf = ^TTextBuf;
  80.   TTextBuf = array[0..127] of Char;
  81.   TTextRec = record
  82.     Handle:    Longint;                 { File Handle                }
  83.     Mode:      Longint;                 { Current file mode          }
  84.     BufSize:   Longint;                 { Text File buffer size      }
  85.     BufPos:    Longint;                 { Buffer current position    }
  86.     BufEnd:    Longint;                 { Buffer ending position     }
  87.     BufPtr:    ^TTextBuf;               { Pointer to the buffer      }
  88.     OpenFunc:  Pointer;                 { Open Text File function @  }
  89.     InOutFunc: Pointer;                 { In/Out ...                 }
  90.     FlushFunc: Pointer;                 { Flush ...                  }
  91.     CloseFunc: Pointer;                 { Close ...                  }
  92.     UserData:  array [1..8] of Byte;    { User data area             }
  93.     Name:      array [0..259] of Char;  { File name (ASCIIZ)         }
  94.     Buffer:    TTextBuf;                { Default I/O buffer         }
  95.   end;
  96.  
  97. { Search record used by FindFirst and FindNext }
  98.  
  99. type
  100.   TSearchRec = record
  101.     HDir: Longint;
  102.     Attr: Byte;
  103.     Time: Longint;
  104.     Size: Longint;
  105.     Name: array[0..fsFileName] of Char;
  106.   end;
  107.  
  108. { Date and time record used by PackTime and UnpackTime }
  109.  
  110. type
  111.   TDateTime = record
  112.     Year, Month, Day, Hour, Min, Sec: Word;
  113.   end;
  114.  
  115. { Error status variable }
  116.  
  117. var
  118.   DosError: Integer;
  119.  
  120. function DosVersion: Word;
  121. procedure GetDate(var Year, Month, Day, DayOfWeek: Word);
  122. procedure SetDate(Year, Month, Day: Word);
  123. procedure GetTime(var Hour, Minute, Second, Sec100: Word);
  124. procedure SetTime(Hour, Minute, Second, Sec100: Word);
  125. procedure GetVerify(var Verify: Boolean);
  126. procedure SetVerify(Verify: Boolean);
  127. function DiskFree(Drive: Byte): Longint;
  128. function DiskSize(Drive: Byte): Longint;
  129. procedure GetFAttr(var F; var Attr: Word);
  130. procedure SetFAttr(var F; Attr: Word);
  131. procedure GetFTime(var F; var Time: Longint);
  132. procedure SetFTime(var F; Time: Longint);
  133. procedure FindFirst(Path: PChar; Attr: Word; var F: TSearchRec);
  134. procedure FindNext(var F: TSearchRec);
  135. procedure UnpackTime(P: Longint; var T: TDateTime);
  136. procedure PackTime(var T: TDateTime; var P: Longint);
  137. function FileSearch(Dest, Name, List: PChar): PChar;
  138. function FileExpand(Dest, Name: PChar): PChar;
  139. function FileSplit(Path, Dir, Name, Ext: PChar): Word;
  140. function GetCurDir(Dir: PChar; Drive: Byte): PChar;
  141. procedure SetCurDir(Dir: PChar);
  142. procedure CreateDir(Dir: PChar);
  143. procedure RemoveDir(Dir: PChar);
  144. function GetArgCount: Integer;
  145. function GetArgStr(Dest: PChar; Index: Integer; MaxLen: Word): PChar;
  146. function GetEnvVar(VarName: PChar): PChar;
  147.  
  148. { The following procedures are not implemented
  149.  
  150. procedure Intr(IntNo: Byte; var Regs: TRegisters);
  151. procedure MsDos(var Regs: TRegisters);
  152. procedure GetCBreak(var Break: Boolean);
  153. procedure SetCBreak(Break: Boolean);
  154. procedure GetIntVec(IntNo: Byte; var Vector: Pointer);
  155. procedure SetIntVec(IntNo: Byte; Vector: Pointer);
  156.  
  157. }
  158.  
  159. { The following procedure is added }
  160.  
  161. procedure FindClose(var F: TSearchRec);
  162.  
  163. implementation
  164.  
  165. uses Os2Def, Os2Base, Strings;
  166.  
  167. type
  168.   DateTime = TDateTime;
  169.   FileRec  = TFileRec;
  170.  
  171. {$I DOS.INC}    { Common Dos and WinDos procedures and functions }
  172.  
  173. { Searches the specified (or current) directory for the first entry     }
  174. { that matches the specified filename and attributes. The result is     }
  175. { returned in the specified search record. Errors (and no files found)  }
  176. { are reported in DosError.                                             }
  177.  
  178. procedure FindFirst(Path: PChar; Attr: Word; var F: TSearchRec);
  179. var
  180.   Count: ULong;
  181.   SR: FileFindBuf3;
  182. begin
  183.   Count := 1;
  184.   F.HDir := hdir_Create;
  185.   DosError := DosFindFirst(Path,F.HDir,Attr,SR,SizeOf(SR),Count,fil_Standard);
  186.   if DosError = 0 then
  187.     with F,SR do
  188.     begin
  189.       Attr := attrFile;
  190.       DateTimeRec(Time).FTime := ftimeLastWrite;
  191.       DateTimeRec(Time).FDate := fdateLastWrite;
  192.       Size := cbFile;
  193.       StrPCopy(Name, achName);
  194.     end;
  195. end;
  196.  
  197. { Returs the next entry that matches the name and attributes specified  }
  198. { in a previous call to FindFirst. The search record must be one passed }
  199. { to FindFirst. Errors (and no more files) are reported in DosError.    }
  200.  
  201. procedure FindNext(var F: TSearchRec);
  202. var
  203.   Count: ULong;
  204.   SR: FileFindBuf3;
  205. begin
  206.   Count := 1;
  207.   DosError := DosFindNext(F.HDir,SR,SizeOf(SR),Count);
  208.   if DosError = 0 then
  209.     with F,SR do
  210.     begin
  211.       Attr := attrFile;
  212.       DateTimeRec(Time).FTime := ftimeLastWrite;
  213.       DateTimeRec(Time).FDate := fdateLastWrite;
  214.       Size := cbFile;
  215.       StrPCopy(Name, achName);
  216.     end;
  217. end;
  218.  
  219. { Ends the search, closes the search record. FindClose should be issued }
  220. { whenever search record is no longer needed. Unlike DOS, OS/2 does not }
  221. { keep search information in the user program space (in the SearchRec). }
  222. { OS/2 returns only handle that identifies this information, so it      }
  223. { should be freed, otherwise OS/2 runs out of search handles and all    }
  224. { calls to FindFirst later on will fail. If search record is invalid    }
  225. { then error is reported in DosError.                                   }
  226.  
  227. procedure FindClose(var F: TSearchRec);
  228. begin
  229.   DosError := DosFindClose(F.HDir);
  230. end;
  231.  
  232. { FileSearch searches for the file given by Name in the list of         }
  233. { directories given by List. The directory paths in List must be        }
  234. { separated by semicolons. The search always starts with the current    }
  235. { directory of the current drive. If the file is found, FileSearch      }
  236. { stores a concatenation of the directory path and the file name in     }
  237. { Dest. Otherwise FileSearch stores an empty string in Dest. The        }
  238. { maximum length of the result is defined by the fsPathName constant.   }
  239. { The returned value is Dest.                                           }
  240.  
  241. function FileSearch(Dest, Name, List: PChar): PChar;
  242. var
  243.   Info: FileStatus3;
  244. begin
  245.   if (DosQueryPathInfo(Name,fil_Standard,Info,SizeOf(Info)) = 0)
  246.     and ((Info.attrFile and faDirectory) = 0) then FileExpand(Dest, Name)
  247.  else
  248.   if DosSearchPath(dsp_ImpliedCur+dsp_IgnoreNetErr,List,Name,Dest,fsPathName+1) <> 0
  249.     then Dest[0] := #0;
  250.   FileSearch := Dest;
  251. end;
  252.  
  253. { FileExpand fully expands the file name in Name, and stores the result }
  254. { in Dest. The maximum length of the result is defined by the           }
  255. { fsPathName constant. The result is an all upper case string           }
  256. { consisting of a drive letter, a colon, a root relative directory path,}
  257. { and a file name. Embedded '.' and '..' directory references are       }
  258. { removed. The returned value is Dest.                                  }
  259.  
  260. function FileExpand(Dest, Name: PChar): PChar;
  261. var
  262.   I,J,L: Integer;
  263.   C: Char;
  264.   CurDir: String;
  265.  
  266. procedure AdjustPath;
  267. begin
  268.   { Check for '\.\' }
  269.   if (Dest[J-2] = '\') and (Dest[J-1] = '.') then Dec(J,2)
  270.  else
  271.   { Check for '\..\' }
  272.   if (Dest[J-3] = '\') and (Dest[J-2] = '.') and (Dest[J-1] = '.') then
  273.   begin
  274.     Dec(J,3);
  275.     if Dest[J-1] <> ':' then
  276.     repeat
  277.       Dec(J);
  278.     until Dest[J] = '\';
  279.   end;
  280. end;
  281.  
  282. begin
  283.   L := StrLen(Name);
  284.   if (L >= 2) and (Name[1] = ':') then
  285.   begin                         { Path is already in form 'X:\Path'     }
  286.     if (L >= 3) and (Name[2] = '\') then StrCopy(Dest, Name)
  287.    else
  288.     begin                       { Path is in form 'X:Path'              }
  289.       GetDir(Ord(UpCase(Name[0])) - Ord('A') + 1, CurDir);
  290.       if Length(CurDir) > 3 then CurDir := CurDir + '\';
  291.       StrLCat(StrPCopy(Dest, CurDir), @Name[2], fsPathName);
  292.     end;
  293.   end
  294.  else
  295.   begin                         { Path is without drive letter          }
  296.     GetDir(0,CurDir);           { Get default drive & directory         }
  297.     if Length(CurDir) > 3 then CurDir := CurDir + '\';
  298.     if Name[0] = '\' then StrLCopy(Dest, @CurDir[1], 2) { only 'X:'     }
  299.                      else StrPCopy(Dest, CurDir);
  300.     StrLCat(Dest, Name, fsPathName);
  301.   end;
  302.   I := 0; J := 0;
  303.   for I := 0 to StrLen(Dest)-1 do
  304.   begin
  305.     C := UpCase(Dest[I]);
  306.     if C = '\' then AdjustPath;
  307.     Dest[J] := C;
  308.     Inc(J);
  309.   end;
  310.   AdjustPath;
  311.   if Dest[J-1] = ':' then
  312.   begin
  313.     Dest[J] := '\';
  314.     Inc(J);
  315.   end;
  316.   Dest[J] := #0;
  317.   FileExpand := Dest;
  318. end;
  319.  
  320. { FileSplit splits the file name specified by Path into its three       }
  321. { components. Dir is set to the drive and directory path with any       }
  322. { leading and trailing backslashes, Name is set to the file name, and   }
  323. { Ext is set to the extension with a preceding period. If a component   }
  324. { string parameter is NIL, the corresponding part of the path is not    }
  325. { stored. If the path does not contain a given component, the returned  }
  326. { component string is empty. The maximum lengths of the strings         }
  327. { returned in Dir, Name, and Ext are defined by the fsDirectory,        }
  328. { fsFileName, and fsExtension constants. The returned value is a        }
  329. { combination of the fcDirectory, fcFileName, and fcExtension bit masks,}
  330. { indicating which components were present in the path. If the name or  }
  331. { extension contains any wildcard characters (* or ?), the fcWildcards  }
  332. { flag is set in the returned value.                                    }
  333.  
  334. function FileSplit(Path, Dir, Name, Ext: PChar): Word;
  335. var
  336.   DirLen, NameLen, Flags: Word;
  337.   NamePtr, ExtPtr: PChar;
  338. begin
  339.   NamePtr := StrRScan(Path, '\');
  340.   if NamePtr = nil then NamePtr := StrRScan(Path, ':');
  341.   if NamePtr = nil then NamePtr := Path else Inc(NamePtr);
  342.   ExtPtr := StrScan(NamePtr, '.');
  343.   if ExtPtr = nil then ExtPtr := StrEnd(NamePtr);
  344.   DirLen := NamePtr - Path;
  345.   if DirLen > fsDirectory then DirLen := fsDirectory;
  346.   NameLen := ExtPtr - NamePtr;
  347.   if NameLen > fsFilename then NameLen := fsFilename;
  348.   Flags := 0;
  349.   if (StrScan(NamePtr, '?') <> nil) or (StrScan(NamePtr, '*') <> nil) then
  350.     Flags := fcWildcards;
  351.   if DirLen <> 0 then Flags := Flags or fcDirectory;
  352.   if NameLen <> 0 then Flags := Flags or fcFilename;
  353.   if ExtPtr[0] <> #0 then Flags := Flags or fcExtension;
  354.   if Dir <> nil then StrLCopy(Dir, Path, DirLen);
  355.   if Name <> nil then StrLCopy(Name, NamePtr, NameLen);
  356.   if Ext <> nil then StrLCopy(Ext, ExtPtr, fsExtension);
  357.   FileSplit := Flags;
  358. end;
  359.  
  360. { GetCurDir returns the current directory of a specified drive.         }
  361. { Drive = 0 indicates the current drive, 1 indicates drive A, 2         }
  362. { indicates drive B, and so on. The string returned in Dir always       }
  363. { starts with a drive letter, a colon, and a backslash. The maximum     }
  364. { length of the resulting string is defined by the fsDirectory constant.}
  365. { The returned value is Dir. Errors are reported in DosError.           }
  366.  
  367. function GetCurDir(Dir: PChar; Drive: Byte): PChar;
  368. var
  369.   S: String;
  370. begin
  371.   GetDir(Drive, S);
  372.   ChDir(S);
  373.   DosError := IOResult;
  374.   GetCurDir := StrPCopy(Dir, S);
  375. end;
  376.  
  377. { SetCurDir changes the current directory to the path specified by Dir. }
  378. { If Dir specifies a drive letter, the current drive is also changed.   }
  379. { Errors are reported in DosError.                                      }
  380.  
  381. procedure SetCurDir(Dir: PChar);
  382. begin
  383.   ChDir(StrPas(Dir));
  384.   DosError := IOResult;
  385. end;
  386.  
  387. { CreateDir creates a new subdirectory with the path specified by Dir.  }
  388. { Errors are reported in DosError.                                      }
  389.  
  390. procedure CreateDir(Dir: PChar);
  391. begin
  392.   MkDir(StrPas(Dir));
  393.   DosError := IOResult;
  394. end;
  395.  
  396. { RemoveDir removes the subdirectory with the path specified by Dir.    }
  397. { Errors are reported in DosError.                                      }
  398.  
  399. procedure RemoveDir(Dir: PChar);
  400. begin
  401.   RmDir(StrPas(Dir));
  402.   DosError := IOResult;
  403. end;
  404.  
  405. { GetArgCount returns the number of parameters passed to the program on }
  406. { the command line.                                                     }
  407.  
  408. function GetArgCount: Integer;
  409. begin
  410.   GetArgCount := ParamCount;
  411. end;
  412.  
  413. { GetArgStr returns the Index'th parameter from the command line, or an }
  414. { empty string if Index is less than zero or greater than GetArgCount.  }
  415. { If Index is zero, GetArgStr returns the filename of the current       }
  416. { module. The maximum length of the string returned in Dest is given by }
  417. { the MaxLen parameter. The returned value is Dest.                     }
  418.  
  419. function GetArgStr(Dest: PChar; Index: Integer; MaxLen: Word): PChar;
  420. var
  421.   S: String;
  422. begin
  423.   if MaxLen > 255 then MaxLen := 255;
  424.   S := ParamStr(Index);
  425.   if Length(S) > MaxLen then S[0] := Chr(MaxLen);
  426.   GetArgStr := StrPCopy(Dest, S);
  427. end;
  428.  
  429. { GetEnvVar returns a pointer to the value of a specified environment   }
  430. { variable, i.e. a pointer to the first character after the equals sign }
  431. { (=) in the environment entry given by VarName. VarName is case        }
  432. { insensitive. GetEnvVar returns NIL if the specified environment       }
  433. { variable does not exist.                                              }
  434.  
  435. function GetEnvVar(VarName: PChar): PChar;
  436. var
  437.   L: Word;
  438.   P: PChar;
  439. begin
  440.   L := StrLen(VarName);
  441.   P := Environment;
  442.   while P^ <> #0 do
  443.   begin
  444.     if (StrLIComp(P, VarName, L) = 0) and (P[L] = '=') then
  445.     begin
  446.       GetEnvVar := P + L + 1;
  447.       Exit;
  448.     end;
  449.     Inc(P, StrLen(P) + 1);
  450.   end;
  451.   GetEnvVar := nil;
  452. end;
  453.  
  454. end.
  455.