home *** CD-ROM | disk | FTP | other *** search
/ Software of the Month Club 1995 December / SOFM_Dec1995.bin / pc / os2 / vpascal / source / rtl / dos.pas < prev    next >
Pascal/Delphi Source File  |  1995-10-31  |  15KB  |  462 lines
  1. {█▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀█}
  2. {█                                                       █}
  3. {█      Virtual Pascal Runtime Library.  Version 1.0.    █}
  4. {█      DOS interface unit for OS/2                      █}
  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 Dos;
  15.  
  16. interface
  17.  
  18. uses Os2Def, Os2Base, 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.   ReadOnly  = $01;
  41.   Hidden    = $02;
  42.   SysFile   = $04;
  43.   VolumeID  = $08;      { For compatibility only, OS/2 doesn't use this attribute }
  44.   Directory = $10;
  45.   Archive   = $20;
  46.   AnyFile   = $37;
  47.  
  48. type
  49.  
  50. { String types }
  51.  
  52.   ComStr  = String;     { Command line string           }
  53.   PathStr = String;     { File pathname string          }
  54.   DirStr  = String;     { Drive and directory string    }
  55.   NameStr = String;     { File name string              }
  56.   ExtStr  = String;     { File extension string         }
  57.  
  58. { Typed-file and untyped-file record }
  59.  
  60.   FileRec = record
  61.     Handle:   Longint;                  { File Handle                }
  62.     Mode:     Longint;                  { Current file mode          }
  63.     RecSize:  Longint;                  { I/O operation record size  }
  64.     Private:  array [1..28] of Byte;    { Reserved                   }
  65.     UserData: array [1..8] of Byte;     { User data area             }
  66.     Name:     array [0..259] of Char;   { File name (ASCIIZ)         }
  67.   end;
  68.  
  69. { Textfile record }
  70.  
  71.   TextBuf = array [0..127] of Char;
  72.   TextRec = record
  73.     Handle:    Longint;                 { File Handle                }
  74.     Mode:      Longint;                 { Current file mode          }
  75.     BufSize:   Longint;                 { Text File buffer size      }
  76.     BufPos:    Longint;                 { Buffer current position    }
  77.     BufEnd:    Longint;                 { Buffer ending position     }
  78.     BufPtr:    ^TextBuf;                { Pointer to the buffer      }
  79.     OpenFunc:  Pointer;                 { Open Text File function @  }
  80.     InOutFunc: Pointer;                 { In/Out ...                 }
  81.     FlushFunc: Pointer;                 { Flush ...                  }
  82.     CloseFunc: Pointer;                 { Close ...                  }
  83.     UserData:  array [1..8] of Byte;    { User data area             }
  84.     Name:      array [0..259] of Char;  { File name (ASCIIZ)         }
  85.     Buffer:    array [0..127] of Char;  { Default I/O buffer         }
  86.   end;
  87.  
  88. { Search record used by FindFirst and FindNext }
  89.  
  90.   SearchRec = record
  91.     HDir: ULong;
  92.     Attr: Byte;
  93.     Time: Longint;
  94.     Size: Longint;
  95.     Name: NameStr;
  96.   end;
  97.  
  98. { Date and time record used by PackTime and UnpackTime }
  99.  
  100.   DateTime = record
  101.     Year,Month,Day,Hour,Min,Sec: Word;
  102.   end;
  103.  
  104. { Error status variable }
  105.  
  106. const
  107.   DosError: Integer = 0;
  108.  
  109. { Exec flags }
  110. const
  111.   efSync  = exec_Sync;
  112.   efAsync = exec_AsyncResult;
  113.  
  114. const
  115.   ExecFlags: ULong = exec_Sync;
  116.  
  117. function DosVersion: Word;
  118. procedure GetDate(var Year,Month,Day,DayOfWeek: Word);
  119. procedure SetDate(Year,Month,Day: Word);
  120. procedure GetTime(var Hour,Minute,Second,Sec100: Word);
  121. procedure SetTime(Hour,Minute,Second,Sec100: Word);
  122. procedure GetVerify(var Verify: Boolean);
  123. procedure SetVerify(Verify: Boolean);
  124. function DiskFree(Drive: Byte): Longint;
  125. function DiskSize(Drive: Byte): Longint;
  126. procedure GetFAttr(var F; var Attr: Word);
  127. procedure SetFAttr(var F; Attr: Word);
  128. procedure GetFTime(var F; var Time: Longint);
  129. procedure SetFTime(var F; Time: Longint);
  130. procedure FindFirst(const Path: PathStr; Attr: Word; var F: SearchRec);
  131. procedure FindNext(var F: SearchRec);
  132. procedure UnpackTime(P: Longint; var T: DateTime);
  133. procedure PackTime(var T: DateTime; var P: Longint);
  134. function FSearch(const Path: PathStr; const DirList: String): PathStr;
  135. function FExpand(const Path: PathStr): PathStr;
  136. function EnvCount: Integer;
  137. function EnvStr(Index: Integer): String;
  138. function GetEnv(const EnvVar: String): String;
  139. procedure FSplit(const Path: PathStr; var Dir: DirStr; var Name: NameStr;
  140.   var Ext: ExtStr);
  141. procedure Exec(const Path: PathStr; const ComLine: ComStr);
  142. function DosExitCode: Word;
  143.  
  144. { The following procedures are not implemented
  145.  
  146. procedure Intr(IntNo: Byte; var Regs: Registers);
  147. procedure MsDos(var Regs: Registers);
  148. procedure GetCBreak(var Break: Boolean);
  149. procedure SetCBreak(Break: Boolean);
  150. procedure GetIntVec(IntNo: Byte; var Vector: Pointer);
  151. procedure SetIntVec(IntNo: Byte; Vector: Pointer);
  152. procedure Keep(ExitCode: Word);
  153.  
  154. }
  155.  
  156. { SwapVectors remains for compatibility but do nothing }
  157.  
  158. procedure SwapVectors;
  159.  
  160. { The following procedure is added }
  161.  
  162. procedure FindClose(var F: SearchRec);
  163.  
  164. implementation
  165.  
  166. uses Strings;
  167.  
  168. { Synchronous Exec result is placed here }
  169.  
  170. var
  171.   ExecResult: ResultCodes;
  172.  
  173. {$I DOS.INC}    { Common Dos and WinDos procedures and functions }
  174.  
  175. { Searches the specified (or current) directory for the first entry     }
  176. { that matches the specified filename and attributes. The result is     }
  177. { returned in the specified search record. Errors (and no files found)  }
  178. { are reported in DosError.                                             }
  179.  
  180. procedure FindFirst(const Path: PathStr; Attr: Word; var F: SearchRec);
  181. var
  182.   Count: ULong;
  183.   SR: FileFindBuf3;
  184.   PathZ: array [0..SizeOf(PathStr)-1] of Char;
  185. begin
  186.   StrPCopy(PathZ, Path);
  187.   Count := 1;
  188.   F.HDir := hdir_Create;
  189.   DosError := DosFindFirst(PathZ,F.HDir,Attr,SR,SizeOf(SR),Count,fil_Standard);
  190.   if DosError = 0 then
  191.     with F,SR do
  192.     begin
  193.       Attr := attrFile;
  194.       DateTimeRec(Time).FTime := ftimeLastWrite;
  195.       DateTimeRec(Time).FDate := fdateLastWrite;
  196.       Size := cbFile;
  197.       Name := achName;
  198.     end;
  199. end;
  200.  
  201. { Returs the next entry that matches the name and attributes specified  }
  202. { in a previous call to FindFirst. The search record must be one passed }
  203. { to FindFirst. Errors (and no more files) are reported in DosError.    }
  204.  
  205. procedure FindNext(var F: SearchRec);
  206. var
  207.   Count: ULong;
  208.   SR: FileFindBuf3;
  209. begin
  210.   Count := 1;
  211.   DosError := DosFindNext(F.HDir,SR,SizeOf(SR),Count);
  212.   if DosError = 0 then
  213.     with F,SR do
  214.     begin
  215.       Attr := attrFile;
  216.       DateTimeRec(Time).FTime := ftimeLastWrite;
  217.       DateTimeRec(Time).FDate := fdateLastWrite;
  218.       Size := cbFile;
  219.       Name := achName;
  220.     end;
  221. end;
  222.  
  223. { Ends the search, closes the search record. FindClose should be issued }
  224. { whenever search record is no longer needed. Unlike DOS, OS/2 does not }
  225. { keep search information in the user program space (in the SearchRec). }
  226. { OS/2 returns only handle that identifies this information, so it      }
  227. { should be freed, otherwise OS/2 runs out of search handles and all    }
  228. { calls to FindFirst later on will fail. If search record is invalid    }
  229. { then error is reported in DosError.                                   }
  230.  
  231. procedure FindClose(var F: SearchRec);
  232. begin
  233.   DosError := DosFindClose(F.HDir);
  234. end;
  235.  
  236. { Searches for the file given by Path in the list of directories given  }
  237. { by DirList. The directory paths in DirList must be separated by       }
  238. { semicolons. The search always starts with the current directory of    }
  239. { the current drive. The returned value is a fully qualified file name  }
  240. { or an empty string if the file could not be located.                  }
  241.  
  242. function FSearch(const Path: PathStr; const DirList: String): PathStr;
  243. var
  244.   Info: FileStatus3;
  245.   PathZ:    array [0..SizeOf(PathStr)-1] of Char;
  246.   DirListZ: array [0..SizeOf(String) -1] of Char;
  247.   Result:   array [0..SizeOf(PathStr)-1] of Char;
  248. begin
  249.   StrPCopy(PathZ, Path);
  250.   StrPCopy(DirListZ, DirList);
  251.   if DosQueryPathInfo(PathZ,fil_Standard,Info,SizeOf(Info)) = 0 then
  252.     if (Info.attrFile and Directory) = 0 then
  253.     begin
  254.       FSearch := FExpand(Path);
  255.       Exit;
  256.     end;
  257.   if DosSearchPath(dsp_ImpliedCur+dsp_IgnoreNetErr,DirListZ,PathZ,Result,SizeOf(Result)) = 0
  258.     then FSearch := StrPas(Result)
  259.     else FSearch := '';
  260. end;
  261.  
  262. { FExpand expands the file name in Path into a fully qualified file     }
  263. { name. The resulting name consists of a drive letter, a colon, a root  }
  264. { relative directory path, and a file name. Embedded '.' and '..'       }
  265. { directory references are removed.                                     }
  266.  
  267. function FExpand(const Path: PathStr): PathStr;
  268. var
  269.   I,J: Integer;
  270.   C: Char;
  271.   S,CurDir: String;
  272.  
  273. procedure AdjustPath;
  274. begin
  275.   { Check for '\.\' }
  276.   if (S[J-2] = '\') and (S[J-1] = '.') then Dec(J,2)
  277.  else
  278.   { Check for '\..\' }
  279.   if (S[J-3] = '\') and (S[J-2] = '.') and (S[J-1] = '.') then
  280.   begin
  281.     Dec(J,3);
  282.     if S[J-1] <> ':' then
  283.     repeat
  284.       Dec(J);
  285.     until S[J] = '\';
  286.   end;
  287. end;
  288.  
  289. begin
  290.   if (Length(Path) >= 2) and (Path[2] = ':') then
  291.   begin                                 { Path is already in form 'X:\Path }
  292.     if (Length(Path) >= 3) and (Path[3] = '\') then S := Path
  293.    else
  294.     begin                               { Path is in form 'X:Path'      }
  295.       GetDir(Ord(UpCase(Path[1])) - Ord('A') + 1, CurDir);
  296.       if Length(CurDir) > 3 then CurDir := CurDir + '\';
  297.       S := CurDir + Copy(Path, 3, Length(Path));
  298.     end;
  299.   end
  300.  else
  301.   begin                                 { Path is without drive letter  }
  302.     GetDir(0,CurDir);                   { Get default drive & directory }
  303.     if Length(CurDir) > 3 then CurDir := CurDir + '\';
  304.     if Path[1] = '\' then S := Copy(CurDir, 1, 2) { only 'X:' }
  305.                      else S := CurDir;
  306.     S := S + Path;
  307.   end;
  308.   I := 1; J := 1;
  309.   for I := 1 to Length(S) do
  310.   begin
  311.     C := UpCase(S[I]);
  312.     if C = '\' then AdjustPath;
  313.     S[J] := C;
  314.     Inc(J);
  315.   end;
  316.   AdjustPath;
  317.   if S[J-1] = ':' then
  318.   begin
  319.     S[J] := '\';
  320.     Inc(J);
  321.   end;
  322.   FExpand := Copy(S, 1, J-1);
  323. end;
  324.  
  325. { EnvCount returns the number of strings contained in the OS/2          }
  326. { environment.                                                          }
  327.  
  328. function EnvCount: Integer;
  329. var
  330.   P: PChar;
  331.   Count: Integer;
  332. begin
  333.   P := Environment;
  334.   Count := 0;
  335.   while P^ <> #0 do
  336.   begin
  337.     repeat Inc(P) until (P-1)^ = #0;
  338.     Inc(Count);
  339.   end;
  340.   EnvCount := Count;
  341. end;
  342.  
  343. { Splits the file name specified by Path into its three components. Dir }
  344. { is set to the drive and directory path with any leading and trailing  }
  345. { backslashes, Name is set to the file name, and Ext is set to the      }
  346. { extension with a preceding dot. Each of the component strings may     }
  347. { possibly be empty, if Path contains no such component.                }
  348.  
  349. procedure FSplit(const Path: PathStr; var Dir: DirStr; var Name: NameStr;
  350.   var Ext: ExtStr);
  351. var
  352.   I,NamePos,ExtPos: Integer;
  353. begin
  354.   NamePos := 0;
  355.   ExtPos  := 256;
  356.   for I := 1 to Length(Path) do
  357.   case Path[I] of
  358.     ':','\':
  359.       begin
  360.         NamePos := I;
  361.         ExtPos  := 256;
  362.       end;
  363.     '.': ExtPos := I;
  364.   end;
  365.   Dir  := Copy(Path, 1, NamePos);
  366.   Name := Copy(Path, NamePos+1, ExtPos-NamePos-1);
  367.   Ext  := Copy(Path, ExtPos, 255);
  368. end;
  369.  
  370. { Returns a specified environment string. The returned string is of the }
  371. { form "VAR=VALUE". The index of the first string is one. If Index is   }
  372. { less than one or greater than EnvCount,EnvStr returns an empty string.}
  373.  
  374. function EnvStr(Index: Integer): String;
  375. var
  376.   P: PChar;
  377.   Count: Integer;
  378. begin
  379.   EnvStr := '';
  380.   if Index > 0 then
  381.   begin
  382.     P := Environment;
  383.     Count := 1;
  384.     while (Count < Index) and (P^ <> #0) do
  385.     begin
  386.       repeat Inc(P) until (P-1)^ = #0;
  387.       Inc(Count);
  388.     end;
  389.     EnvStr := StrPas(P);
  390.   end;
  391. end;
  392.  
  393. { Returns the value of a specified environment variable. The variable   }
  394. { name can be in upper or lower case, but it must not include the '='   }
  395. { character. If the specified environment variable does not exist,      }
  396. { GetEnv returns an empty string.                                       }
  397.  
  398. function GetEnv(const EnvVar: String): String;
  399. var
  400.   P: PChar;
  401.   L: Word;
  402.   EnvVarZ: array [0..SizeOf(String)-1] of Char;
  403. begin
  404.   StrPCopy(EnvVarZ, EnvVar);
  405.   L := Length(EnvVar);
  406.   P := Environment;
  407.   while P^ <> #0 do
  408.   begin
  409.     if (StrLIComp(P, EnvVarZ, L) = 0) and (P[L] = '=') then
  410.     begin
  411.       GetEnv := StrPas(P + L + 1);
  412.       Exit;
  413.     end;
  414.     Inc(P, StrLen(P) + 1);
  415.   end;
  416.   GetEnv := '';
  417. end;
  418.  
  419. { Executes another program. The program is specified by the Path        }
  420. { parameter, and the command line is specified by the CmdLine parameter.}
  421. { ExecFlags specifies Exec type (synchronous or asynchronous). To       }
  422. { execute an OS/2 internal command, run CMD.EXE, e.g.                   }
  423. { "Exec(GetEnv('COMSPEC'),'/C DIR *.PAS');". Note the /C in front of    }
  424. { the command. Errors are reported in DosError.                         }
  425.  
  426. procedure Exec(const Path: PathStr; const ComLine: ComStr);
  427. var
  428.   Times: ULong;
  429.   P: PChar;
  430.   FailedObj: array [0..255] of Char;
  431.   PathZ:     array [0..SizeOf(PathStr)-1] of Char;
  432.   ComLineZ:  array [0..SizeOf(PathStr) + SizeOf(ComStr)] of Char;
  433. begin
  434.   StrPCopy(PathZ, Path);
  435.   P := StrECopy(ComLineZ, PathZ);       { 'Path'#0                  }
  436.   StrPCopy(P+1, ComLine);               { 'Path'#0'CommandLine'#0   }
  437.   P[Length(ComLine)+2] := #0;           { 'Path'#0'CommandLine'#0#0 }
  438.   DosError := DosExecPgm(FailedObj, SizeOf(FailedObj), ExecFlags, ComLineZ,
  439.     Environment, ExecResult, PathZ);
  440. end;
  441.  
  442. { DosExitCode returns the exit code of a sub-process. To obtain the     }
  443. { correct exit code make sure that ExecFlags variable has not been      }
  444. { changed between calls to Exec and DosExitCode.                        }
  445.  
  446. function DosExitCode: Word;
  447. var
  448.   RetPid: Pid;
  449. begin
  450.   if ExecFlags = efAsync then
  451.     DosWaitChild(dcwa_Process,dcww_Wait,ExecResult,RetPid,ExecResult.codeTerminate);
  452.   DosExitCode := ExecResult.codeResult;
  453. end;
  454.  
  455. { Remains for compatibility only }
  456.  
  457. procedure SwapVectors;
  458. begin
  459. end;
  460.  
  461. end.
  462.