sysutils.pp 35 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046
  1. {
  2. This file is part of the Free Pascal run time library.
  3. Copyright (c) 1999-2000 by Florian Klaempfl
  4. member of the Free Pascal development team
  5. Sysutils unit for OS/2
  6. See the file COPYING.FPC, included in this distribution,
  7. for details about the copyright.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  11. **********************************************************************}
  12. unit sysutils;
  13. interface
  14. {$MODE objfpc}
  15. { force ansistrings }
  16. {$H+}
  17. uses
  18. Dos;
  19. {$DEFINE HAS_SLEEP}
  20. { Include platform independent interface part }
  21. {$i sysutilh.inc}
  22. implementation
  23. uses
  24. sysconst;
  25. {$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *)
  26. {$DEFINE FPC_FEXPAND_DRIVES} (* Full paths begin with drive specification *)
  27. { Include platform independent implementation part }
  28. {$i sysutils.inc}
  29. {****************************************************************************
  30. System (imported) calls
  31. ****************************************************************************}
  32. (* "uses DosCalls" could not be used here due to type *)
  33. (* conflicts, so needed parts had to be redefined here). *)
  34. type
  35. TFileStatus = object
  36. end;
  37. PFileStatus = ^TFileStatus;
  38. TFileStatus3 = object (TFileStatus)
  39. DateCreation, {Date of file creation.}
  40. TimeCreation, {Time of file creation.}
  41. DateLastAccess, {Date of last access to file.}
  42. TimeLastAccess, {Time of last access to file.}
  43. DateLastWrite, {Date of last modification of file.}
  44. TimeLastWrite:word; {Time of last modification of file.}
  45. FileSize, {Size of file.}
  46. FileAlloc:cardinal; {Amount of space the file really
  47. occupies on disk.}
  48. AttrFile:cardinal; {Attributes of file.}
  49. end;
  50. PFileStatus3=^TFileStatus3;
  51. TFileStatus4=object(TFileStatus3)
  52. cbList:cardinal; {Length of entire EA set.}
  53. end;
  54. PFileStatus4=^TFileStatus4;
  55. TFileFindBuf3=object(TFileStatus)
  56. NextEntryOffset: cardinal; {Offset of next entry}
  57. DateCreation, {Date of file creation.}
  58. TimeCreation, {Time of file creation.}
  59. DateLastAccess, {Date of last access to file.}
  60. TimeLastAccess, {Time of last access to file.}
  61. DateLastWrite, {Date of last modification of file.}
  62. TimeLastWrite:word; {Time of last modification of file.}
  63. FileSize, {Size of file.}
  64. FileAlloc:cardinal; {Amount of space the file really
  65. occupies on disk.}
  66. AttrFile:cardinal; {Attributes of file.}
  67. Name:shortstring; {Also possible to use as ASCIIZ.
  68. The byte following the last string
  69. character is always zero.}
  70. end;
  71. PFileFindBuf3=^TFileFindBuf3;
  72. TFileFindBuf4=object(TFileStatus)
  73. NextEntryOffset: cardinal; {Offset of next entry}
  74. DateCreation, {Date of file creation.}
  75. TimeCreation, {Time of file creation.}
  76. DateLastAccess, {Date of last access to file.}
  77. TimeLastAccess, {Time of last access to file.}
  78. DateLastWrite, {Date of last modification of file.}
  79. TimeLastWrite:word; {Time of last modification of file.}
  80. FileSize, {Size of file.}
  81. FileAlloc:cardinal; {Amount of space the file really
  82. occupies on disk.}
  83. AttrFile:cardinal; {Attributes of file.}
  84. cbList:longint; {Size of the file's extended attributes.}
  85. Name:shortstring; {Also possible to use as ASCIIZ.
  86. The byte following the last string
  87. character is always zero.}
  88. end;
  89. PFileFindBuf4=^TFileFindBuf4;
  90. TFSInfo = record
  91. case word of
  92. 1:
  93. (File_Sys_ID,
  94. Sectors_Per_Cluster,
  95. Total_Clusters,
  96. Free_Clusters: cardinal;
  97. Bytes_Per_Sector: word);
  98. 2: {For date/time description,
  99. see file searching realted
  100. routines.}
  101. (Label_Date, {Date when volume label was created.}
  102. Label_Time: word; {Time when volume label was created.}
  103. VolumeLabel: ShortString); {Volume label. Can also be used
  104. as ASCIIZ, because the byte
  105. following the last character of
  106. the string is always zero.}
  107. end;
  108. PFSInfo = ^TFSInfo;
  109. TCountryCode=record
  110. Country, {Country to query info about (0=current).}
  111. CodePage: cardinal; {Code page to query info about (0=current).}
  112. end;
  113. PCountryCode=^TCountryCode;
  114. TTimeFmt = (Clock12, Clock24);
  115. TCountryInfo=record
  116. Country, CodePage: cardinal; {Country and codepage requested.}
  117. case byte of
  118. 0:
  119. (DateFormat: cardinal; {1=ddmmyy 2=yymmdd 3=mmddyy}
  120. CurrencyUnit: array [0..4] of char;
  121. ThousandSeparator: char; {Thousands separator.}
  122. Zero1: byte; {Always zero.}
  123. DecimalSeparator: char; {Decimals separator,}
  124. Zero2: byte;
  125. DateSeparator: char; {Date separator.}
  126. Zero3: byte;
  127. TimeSeparator: char; {Time separator.}
  128. Zero4: byte;
  129. CurrencyFormat, {Bit field:
  130. Bit 0: 0=indicator before value
  131. 1=indicator after value
  132. Bit 1: 1=insert space after
  133. indicator.
  134. Bit 2: 1=Ignore bit 0&1, replace
  135. decimal separator with
  136. indicator.}
  137. DecimalPlace: byte; {Number of decimal places used in
  138. currency indication.}
  139. TimeFormat: TTimeFmt; {12/24 hour.}
  140. Reserve1: array [0..1] of word;
  141. DataSeparator: char; {Data list separator}
  142. Zero5: byte;
  143. Reserve2: array [0..4] of word);
  144. 1:
  145. (fsDateFmt: cardinal; {1=ddmmyy 2=yymmdd 3=mmddyy}
  146. szCurrency: array [0..4] of char;
  147. {null terminated currency symbol}
  148. szThousandsSeparator: array [0..1] of char;
  149. {Thousands separator + #0}
  150. szDecimal: array [0..1] of char;
  151. {Decimals separator + #0}
  152. szDateSeparator: array [0..1] of char;
  153. {Date separator + #0}
  154. szTimeSeparator: array [0..1] of char;
  155. {Time separator + #0}
  156. fsCurrencyFmt, {Bit field:
  157. Bit 0: 0=indicator before value
  158. 1=indicator after value
  159. Bit 1: 1=insert space after
  160. indicator.
  161. Bit 2: 1=Ignore bit 0&1, replace
  162. decimal separator with
  163. indicator}
  164. cDecimalPlace: byte; {Number of decimal places used in
  165. currency indication}
  166. fsTimeFmt: byte; {0=12,1=24 hours}
  167. abReserved1: array [0..1] of word;
  168. szDataSeparator: array [0..1] of char;
  169. {Data list separator + #0}
  170. abReserved2: array [0..4] of word);
  171. end;
  172. PCountryInfo=^TCountryInfo;
  173. TRequestData=record
  174. PID, {ID of process that wrote element.}
  175. Data: cardinal; {Information from process writing the data.}
  176. end;
  177. PRequestData=^TRequestData;
  178. {Queue data structure for synchronously started sessions.}
  179. TChildInfo = record
  180. case boolean of
  181. false:
  182. (SessionID,
  183. Return: word); {Return code from the child process.}
  184. true:
  185. (usSessionID,
  186. usReturn: word); {Return code from the child process.}
  187. end;
  188. PChildInfo = ^TChildInfo;
  189. TStartData=record
  190. {Note: to omit some fields, use a length smaller than SizeOf(TStartData).}
  191. Length:word; {Length, in bytes, of datastructure
  192. (24/30/32/50/60).}
  193. Related:word; {Independent/child session (0/1).}
  194. FgBg:word; {Foreground/background (0/1).}
  195. TraceOpt:word; {No trace/trace this/trace all (0/1/2).}
  196. PgmTitle:PChar; {Program title.}
  197. PgmName:PChar; {Filename to program.}
  198. PgmInputs:PChar; {Command parameters (nil allowed).}
  199. TermQ:PChar; {System queue. (nil allowed).}
  200. Environment:PChar; {Environment to pass (nil allowed).}
  201. InheritOpt:word; {Inherit enviroment from shell/
  202. inherit environment from parent (0/1).}
  203. SessionType:word; {Auto/full screen/window/presentation
  204. manager/full screen Dos/windowed Dos
  205. (0/1/2/3/4/5/6/7).}
  206. Iconfile:PChar; {Icon file to use (nil allowed).}
  207. PgmHandle:cardinal; {0 or the program handle.}
  208. PgmControl:word; {Bitfield describing initial state
  209. of windowed sessions.}
  210. InitXPos,InitYPos:word; {Initial top coordinates.}
  211. InitXSize,InitYSize:word; {Initial size.}
  212. Reserved:word;
  213. ObjectBuffer:PChar; {If a module cannot be loaded, its
  214. name will be returned here.}
  215. ObjectBuffLen:cardinal; {Size of your buffer.}
  216. end;
  217. PStartData=^TStartData;
  218. TResultCodes=record
  219. TerminateReason, {0 = Normal termionation.
  220. 1 = Critical error.
  221. 2 = Trapped. (GPE, etc.)
  222. 3 = Killed by DosKillProcess.}
  223. ExitCode:cardinal; {Exit code of child.}
  224. end;
  225. const
  226. ilStandard = 1;
  227. ilQueryEAsize = 2;
  228. ilQueryEAs = 3;
  229. ilQueryFullName = 5;
  230. quFIFO = 0;
  231. quLIFO = 1;
  232. quPriority = 2;
  233. quNoConvert_Address = 0;
  234. quConvert_Address = 4;
  235. {Start the new session independent or as a child.}
  236. ssf_Related_Independent = 0; {Start new session independent
  237. of the calling session.}
  238. ssf_Related_Child = 1; {Start new session as a child
  239. session to the calling session.}
  240. {Start the new session in the foreground or in the background.}
  241. ssf_FgBg_Fore = 0; {Start new session in foreground.}
  242. ssf_FgBg_Back = 1; {Start new session in background.}
  243. {Should the program started in the new session
  244. be executed under conditions for tracing?}
  245. ssf_TraceOpt_None = 0; {No trace.}
  246. ssf_TraceOpt_Trace = 1; {Trace with no notification
  247. of descendants.}
  248. ssf_TraceOpt_TraceAll = 2; {Trace all descendant sessions.
  249. A termination queue must be
  250. supplied and Related must be
  251. ssf_Related_Child (=1).}
  252. {Will the new session inherit open file handles
  253. and environment from the calling process.}
  254. ssf_InhertOpt_Shell = 0; {Inherit from the shell.}
  255. ssf_InhertOpt_Parent = 1; {Inherit from the calling process.}
  256. {Specifies the type of session to start.}
  257. ssf_Type_Default = 0; {Use program's type.}
  258. ssf_Type_FullScreen = 1; {OS/2 full screen.}
  259. ssf_Type_WindowableVIO = 2; {OS/2 window.}
  260. ssf_Type_PM = 3; {Presentation Manager.}
  261. ssf_Type_VDM = 4; {DOS full screen.}
  262. ssf_Type_WindowedVDM = 7; {DOS window.}
  263. {Additional values for Windows programs}
  264. Prog_31_StdSeamlessVDM = 15; {Windows 3.1 program in its
  265. own windowed session.}
  266. Prog_31_StdSeamlessCommon = 16; {Windows 3.1 program in a
  267. common windowed session.}
  268. Prog_31_EnhSeamlessVDM = 17; {Windows 3.1 program in enhanced
  269. compatibility mode in its own
  270. windowed session.}
  271. Prog_31_EnhSeamlessCommon = 18; {Windows 3.1 program in enhanced
  272. compatibility mode in a common
  273. windowed session.}
  274. Prog_31_Enh = 19; {Windows 3.1 program in enhanced
  275. compatibility mode in a full
  276. screen session.}
  277. Prog_31_Std = 20; {Windows 3.1 program in a full
  278. screen session.}
  279. {Specifies the initial attributes for a OS/2 window or DOS window session.}
  280. ssf_Control_Visible = 0; {Window is visible.}
  281. ssf_Control_Invisible = 1; {Window is invisible.}
  282. ssf_Control_Maximize = 2; {Window is maximized.}
  283. ssf_Control_Minimize = 4; {Window is minimized.}
  284. ssf_Control_NoAutoClose = 8; {Window will not close after
  285. the program has ended.}
  286. ssf_Control_SetPos = 32768; {Use InitXPos, InitYPos,
  287. InitXSize, and InitYSize for
  288. the size and placement.}
  289. function DosSetFileInfo (Handle: THandle; InfoLevel: cardinal; AFileStatus: PFileStatus;
  290. FileStatusLen: cardinal): cardinal; cdecl; external 'DOSCALLS' index 218;
  291. function DosQueryFSInfo (DiskNum, InfoLevel: cardinal; var Buffer: TFSInfo;
  292. BufLen: cardinal): cardinal; cdecl; external 'DOSCALLS' index 278;
  293. function DosQueryFileInfo (Handle: THandle; InfoLevel: cardinal;
  294. AFileStatus: PFileStatus; FileStatusLen: cardinal): cardinal; cdecl;
  295. external 'DOSCALLS' index 279;
  296. function DosScanEnv (Name: PChar; var Value: PChar): cardinal; cdecl;
  297. external 'DOSCALLS' index 227;
  298. function DosFindFirst (FileMask: PChar; var Handle: THandle; Attrib: cardinal;
  299. AFileStatus: PFileStatus; FileStatusLen: cardinal;
  300. var Count: cardinal; InfoLevel: cardinal): cardinal; cdecl;
  301. external 'DOSCALLS' index 264;
  302. function DosFindNext (Handle: THandle; AFileStatus: PFileStatus;
  303. FileStatusLen: cardinal; var Count: cardinal): cardinal; cdecl;
  304. external 'DOSCALLS' index 265;
  305. function DosFindClose (Handle: THandle): cardinal; cdecl;
  306. external 'DOSCALLS' index 263;
  307. function DosQueryCtryInfo (Size: cardinal; var Country: TCountryCode;
  308. var Res: TCountryInfo; var ActualSize: cardinal): cardinal; cdecl;
  309. external 'NLS' index 5;
  310. function DosMapCase (Size: cardinal; var Country: TCountryCode;
  311. AString: PChar): cardinal; cdecl; external 'NLS' index 7;
  312. function DosDelete(FileName:PChar): cardinal; cdecl;
  313. external 'DOSCALLS' index 259;
  314. function DosMove(OldFile, NewFile:PChar): cardinal; cdecl;
  315. external 'DOSCALLS' index 271;
  316. function DosQueryPathInfo(FileName:PChar;InfoLevel:cardinal;
  317. AFileStatus:PFileStatus;FileStatusLen:cardinal): cardinal; cdecl;
  318. external 'DOSCALLS' index 223;
  319. function DosSetPathInfo(FileName:PChar;InfoLevel:cardinal;
  320. AFileStatus:PFileStatus;FileStatusLen,
  321. Options:cardinal):cardinal; cdecl;
  322. external 'DOSCALLS' index 219;
  323. function DosOpen(FileName:PChar;var Handle: THandle; var Action: cardinal;
  324. InitSize,Attrib,OpenFlags,FileMode:cardinal;
  325. EA:Pointer):cardinal; cdecl;
  326. external 'DOSCALLS' index 273;
  327. function DosClose(Handle: THandle): cardinal; cdecl;
  328. external 'DOSCALLS' index 257;
  329. function DosRead(Handle:THandle; var Buffer; Count: cardinal;
  330. var ActCount: cardinal): cardinal; cdecl;
  331. external 'DOSCALLS' index 281;
  332. function DosWrite(Handle: THandle; Buffer: pointer; Count: cardinal;
  333. var ActCount: cardinal): cardinal; cdecl;
  334. external 'DOSCALLS' index 282;
  335. function DosSetFilePtr(Handle: THandle; Pos: longint; Method: cardinal;
  336. var PosActual: cardinal): cardinal; cdecl;
  337. external 'DOSCALLS' index 256;
  338. function DosSetFileSize (Handle: THandle; Size: cardinal): cardinal; cdecl;
  339. external 'DOSCALLS' index 272;
  340. procedure DosSleep (MSec: cardinal); cdecl; external 'DOSCALLS' index 229;
  341. function DosCreateQueue (var Handle: THandle; Priority:longint;
  342. Name: PChar): cardinal; cdecl;
  343. external 'QUECALLS' index 16;
  344. function DosReadQueue (Handle: THandle; var ReqBuffer: TRequestData;
  345. var DataLen: cardinal; var DataPtr: pointer;
  346. Element, Wait: cardinal; var Priority: byte;
  347. ASem: THandle): cardinal; cdecl;
  348. external 'QUECALLS' index 9;
  349. function DosCloseQueue (Handle: THandle): cardinal; cdecl;
  350. external 'QUECALLS' index 11;
  351. function DosStartSession (var AStartData: TStartData;
  352. var SesID, PID: cardinal): cardinal; cdecl;
  353. external 'SESMGR' index 37;
  354. function DosFreeMem(P:pointer):cardinal; cdecl; external 'DOSCALLS' index 304;
  355. function DosExecPgm (ObjName: PChar; ObjLen: longint; ExecFlag: cardinal;
  356. Args, Env: PByteArray; var Res: TResultCodes;
  357. FileName:PChar): cardinal; cdecl;
  358. external 'DOSCALLS' index 283;
  359. type
  360. TDT=packed record
  361. Hour,
  362. Minute,
  363. Second,
  364. Sec100,
  365. Day,
  366. Month: byte;
  367. Year: word;
  368. TimeZone: smallint;
  369. WeekDay: byte;
  370. end;
  371. function DosGetDateTime(var Buf: TDT): cardinal; cdecl;
  372. external 'DOSCALLS' index 230;
  373. {****************************************************************************
  374. File Functions
  375. ****************************************************************************}
  376. const
  377. ofRead = $0000; {Open for reading}
  378. ofWrite = $0001; {Open for writing}
  379. ofReadWrite = $0002; {Open for reading/writing}
  380. doDenyRW = $0010; {DenyAll (no sharing)}
  381. faCreateNew = $00010000; {Create if file does not exist}
  382. faOpenReplace = $00040000; {Truncate if file exists}
  383. faCreate = $00050000; {Create if file does not exist, truncate otherwise}
  384. FindResvdMask = $00003737; {Allowed bits in attribute
  385. specification for DosFindFirst call.}
  386. function FileOpen (const FileName: string; Mode: integer): longint;
  387. Var
  388. Handle: THandle;
  389. Rc, Action: cardinal;
  390. begin
  391. (* DenyNone if sharing not specified. *)
  392. if Mode and 112 = 0 then Mode:=Mode or 64;
  393. Rc:=DosOpen(PChar (FileName), Handle, Action, 0, 0, 1, Mode, nil);
  394. If Rc=0 then
  395. FileOpen:=Handle
  396. else
  397. FileOpen:=feInvalidHandle; //FileOpen:=-RC;
  398. //should return feInvalidHandle(=-1) if fail, other negative returned value are no more errors
  399. end;
  400. function FileCreate (const FileName: string): longint;
  401. Const
  402. Mode = ofReadWrite or faCreate or doDenyRW; (* Sharing to DenyAll *)
  403. Var
  404. Handle: THandle;
  405. RC, Action: cardinal;
  406. Begin
  407. RC:=DosOpen(PChar (FileName), Handle, Action, 0, 0, $12, Mode, Nil);
  408. If RC=0 then
  409. FileCreate:=Handle
  410. else
  411. FileCreate:=-RC;
  412. End;
  413. function FileCreate (const FileName: string; Mode: integer): longint;
  414. begin
  415. FileCreate := FileCreate(FileName);
  416. end;
  417. function FileRead (Handle: longint; var Buffer; Count: longint): longint;
  418. Var
  419. T: cardinal;
  420. begin
  421. DosRead(Handle, Buffer, Count, T);
  422. FileRead := longint (T);
  423. end;
  424. function FileWrite (Handle: longint; const Buffer; Count: longint): longint;
  425. Var
  426. T: cardinal;
  427. begin
  428. DosWrite (Handle, @Buffer, Count, T);
  429. FileWrite := longint (T);
  430. end;
  431. function FileSeek (Handle, FOffset, Origin: longint): longint;
  432. var
  433. npos: cardinal;
  434. begin
  435. if DosSetFilePtr (Handle, FOffset, Origin, npos) = 0 Then
  436. FileSeek:= longint (npos)
  437. else
  438. FileSeek:=-1;
  439. end;
  440. function FileSeek (Handle: longint; FOffset: Int64; Origin: Longint): Int64;
  441. begin
  442. {$warning need to add 64bit call }
  443. Result:=FileSeek(Handle,Longint(Foffset),Longint(Origin));
  444. end;
  445. procedure FileClose (Handle: longint);
  446. begin
  447. DosClose(Handle);
  448. end;
  449. function FileTruncate (Handle, Size: longint): boolean;
  450. begin
  451. FileTruncate:=DosSetFileSize(Handle, Size)=0;
  452. FileSeek(Handle, 0, 2);
  453. end;
  454. function FileAge (const FileName: string): longint;
  455. var Handle: longint;
  456. begin
  457. Handle := FileOpen (FileName, 0);
  458. if Handle <> -1 then
  459. begin
  460. Result := FileGetDate (Handle);
  461. FileClose (Handle);
  462. end
  463. else
  464. Result := -1;
  465. end;
  466. function FileExists (const FileName: string): boolean;
  467. var
  468. SR: TSearchRec;
  469. RC: longint;
  470. begin
  471. FileExists:=False;
  472. if FindFirst (FileName, faAnyFile and not (faDirectory), SR) = 0
  473. then FileExists := True;
  474. FindClose(SR);
  475. end;
  476. type TRec = record
  477. T, D: word;
  478. end;
  479. PSearchRec = ^SearchRec;
  480. function FindFirst (const Path: string; Attr: longint; out Rslt: TSearchRec): longint;
  481. var SR: PSearchRec;
  482. FStat: PFileFindBuf3;
  483. Count: cardinal;
  484. Err: cardinal;
  485. I: cardinal;
  486. begin
  487. New (FStat);
  488. Rslt.FindHandle := THandle ($FFFFFFFF);
  489. Count := 1;
  490. Err := DosFindFirst (PChar (Path), Rslt.FindHandle,
  491. Attr and FindResvdMask, FStat, SizeOf (FStat^), Count, ilStandard);
  492. if (Err = 0) and (Count = 0) then Err := 18;
  493. FindFirst := -Err;
  494. if Err = 0 then
  495. begin
  496. Rslt.Name := FStat^.Name;
  497. Rslt.Size := FStat^.FileSize;
  498. Rslt.Attr := FStat^.AttrFile;
  499. Rslt.ExcludeAttr := 0;
  500. TRec (Rslt.Time).T := FStat^.TimeLastWrite;
  501. TRec (Rslt.Time).D := FStat^.DateLastWrite;
  502. end;
  503. Dispose (FStat);
  504. end;
  505. function FindNext (var Rslt: TSearchRec): longint;
  506. var
  507. SR: PSearchRec;
  508. FStat: PFileFindBuf3;
  509. Count: cardinal;
  510. Err: cardinal;
  511. begin
  512. New (FStat);
  513. Count := 1;
  514. Err := DosFindNext (Rslt.FindHandle, FStat, SizeOf (FStat^),
  515. Count);
  516. if (Err = 0) and (Count = 0) then Err := 18;
  517. FindNext := -Err;
  518. if Err = 0 then
  519. begin
  520. Rslt.Name := FStat^.Name;
  521. Rslt.Size := FStat^.FileSize;
  522. Rslt.Attr := FStat^.AttrFile;
  523. Rslt.ExcludeAttr := 0;
  524. TRec (Rslt.Time).T := FStat^.TimeLastWrite;
  525. TRec (Rslt.Time).D := FStat^.DateLastWrite;
  526. end;
  527. Dispose (FStat);
  528. end;
  529. procedure FindClose (var F: TSearchrec);
  530. var
  531. SR: PSearchRec;
  532. begin
  533. DosFindClose (F.FindHandle);
  534. F.FindHandle := 0;
  535. end;
  536. function FileGetDate (Handle: longint): longint;
  537. var
  538. FStat: TFileStatus3;
  539. Time: Longint;
  540. begin
  541. DosError := DosQueryFileInfo(Handle, ilStandard, @FStat, SizeOf(FStat));
  542. if DosError=0 then
  543. begin
  544. Time := FStat.TimeLastWrite + longint (FStat.DateLastWrite) shl 16;
  545. if Time = 0 then
  546. Time := FStat.TimeCreation + longint (FStat.DateCreation) shl 16;
  547. end else
  548. Time:=0;
  549. FileGetDate:=Time;
  550. end;
  551. function FileSetDate (Handle, Age: longint): longint;
  552. var
  553. FStat: PFileStatus3;
  554. RC: cardinal;
  555. begin
  556. New (FStat);
  557. RC := DosQueryFileInfo (Handle, ilStandard, FStat, SizeOf (FStat^));
  558. if RC <> 0 then
  559. FileSetDate := -1
  560. else
  561. begin
  562. FStat^.DateLastAccess := Hi (Age);
  563. FStat^.DateLastWrite := Hi (Age);
  564. FStat^.TimeLastAccess := Lo (Age);
  565. FStat^.TimeLastWrite := Lo (Age);
  566. RC := DosSetFileInfo (Handle, ilStandard, FStat, SizeOf (FStat^));
  567. if RC <> 0 then
  568. FileSetDate := -1
  569. else
  570. FileSetDate := 0;
  571. end;
  572. Dispose (FStat);
  573. end;
  574. function FileGetAttr (const FileName: string): longint;
  575. var
  576. FS: PFileStatus3;
  577. begin
  578. New(FS);
  579. Result:=-DosQueryPathInfo(PChar (FileName), ilStandard, FS, SizeOf(FS^));
  580. If Result=0 Then Result:=FS^.attrFile;
  581. Dispose(FS);
  582. end;
  583. function FileSetAttr (const Filename: string; Attr: longint): longint;
  584. Var
  585. FS: PFileStatus3;
  586. Begin
  587. New(FS);
  588. FillChar(FS, SizeOf(FS^), 0);
  589. FS^.AttrFile:=Attr;
  590. Result:=-DosSetPathInfo(PChar (FileName), ilStandard, FS, SizeOf(FS^), 0);
  591. Dispose(FS);
  592. end;
  593. function DeleteFile (const FileName: string): boolean;
  594. Begin
  595. Result:=(DosDelete(PChar (FileName))=0);
  596. End;
  597. function RenameFile (const OldName, NewName: string): boolean;
  598. Begin
  599. Result:=(DosMove(PChar (OldName), PChar (NewName))=0);
  600. End;
  601. {****************************************************************************
  602. Disk Functions
  603. ****************************************************************************}
  604. function DiskFree (Drive: byte): int64;
  605. var FI: TFSinfo;
  606. RC: cardinal;
  607. begin
  608. {In OS/2, we use the filesystem information.}
  609. RC := DosQueryFSInfo (Drive, 1, FI, SizeOf (FI));
  610. if RC = 0 then
  611. DiskFree := int64 (FI.Free_Clusters) *
  612. int64 (FI.Sectors_Per_Cluster) * int64 (FI.Bytes_Per_Sector)
  613. else
  614. DiskFree := -1;
  615. end;
  616. function DiskSize (Drive: byte): int64;
  617. var FI: TFSinfo;
  618. RC: cardinal;
  619. begin
  620. {In OS/2, we use the filesystem information.}
  621. RC := DosQueryFSinfo (Drive, 1, FI, SizeOf (FI));
  622. if RC = 0 then
  623. DiskSize := int64 (FI.Total_Clusters) *
  624. int64 (FI.Sectors_Per_Cluster) * int64 (FI.Bytes_Per_Sector)
  625. else
  626. DiskSize := -1;
  627. end;
  628. function GetCurrentDir: string;
  629. begin
  630. GetDir (0, Result);
  631. end;
  632. function SetCurrentDir (const NewDir: string): boolean;
  633. begin
  634. {$I-}
  635. {$WARNING Should be rewritten to avoid unit dos dependancy!}
  636. ChDir (NewDir);
  637. Result := (IOResult = 0);
  638. {$I+}
  639. end;
  640. function CreateDir (const NewDir: string): boolean;
  641. begin
  642. {$I-}
  643. {$WARNING Should be rewritten to avoid unit dos dependancy!}
  644. MkDir (NewDir);
  645. Result := (IOResult = 0);
  646. {$I+}
  647. end;
  648. function RemoveDir (const Dir: string): boolean;
  649. begin
  650. {$I-}
  651. {$WARNING Should be rewritten to avoid unit dos dependancy!}
  652. RmDir (Dir);
  653. Result := (IOResult = 0);
  654. {$I+}
  655. end;
  656. function DirectoryExists (const Directory: string): boolean;
  657. var
  658. SR: TSearchRec;
  659. begin
  660. DirectoryExists := (FindFirst (Directory, faAnyFile, SR) = 0) and
  661. (SR.Attr and faDirectory <> 0);
  662. FindClose(SR);
  663. end;
  664. {****************************************************************************
  665. Time Functions
  666. ****************************************************************************}
  667. procedure GetLocalTime (var SystemTime: TSystemTime);
  668. var
  669. DT: TDT;
  670. begin
  671. DosGetDateTime(DT);
  672. with SystemTime do
  673. begin
  674. Year:=DT.Year;
  675. Month:=DT.Month;
  676. Day:=DT.Day;
  677. Hour:=DT.Hour;
  678. Minute:=DT.Minute;
  679. Second:=DT.Second;
  680. MilliSecond:=DT.Sec100;
  681. end;
  682. end;
  683. {****************************************************************************
  684. Misc Functions
  685. ****************************************************************************}
  686. procedure Beep;
  687. begin
  688. end;
  689. {****************************************************************************
  690. Locale Functions
  691. ****************************************************************************}
  692. procedure InitAnsi;
  693. var I: byte;
  694. Country: TCountryCode;
  695. begin
  696. for I := 0 to 255 do
  697. UpperCaseTable [I] := Chr (I);
  698. Move (UpperCaseTable, LowerCaseTable, SizeOf (UpperCaseTable));
  699. FillChar (Country, SizeOf (Country), 0);
  700. DosMapCase (SizeOf (UpperCaseTable), Country, @UpperCaseTable);
  701. for I := 0 to 255 do
  702. if UpperCaseTable [I] <> Chr (I) then
  703. LowerCaseTable [Ord (UpperCaseTable [I])] := Chr (I);
  704. end;
  705. procedure InitInternational;
  706. var Country: TCountryCode;
  707. CtryInfo: TCountryInfo;
  708. Size: cardinal;
  709. RC: cardinal;
  710. begin
  711. Size := 0;
  712. FillChar (Country, SizeOf (Country), 0);
  713. FillChar (CtryInfo, SizeOf (CtryInfo), 0);
  714. RC := DosQueryCtryInfo (SizeOf (CtryInfo), Country, CtryInfo, Size);
  715. if RC = 0 then
  716. begin
  717. DateSeparator := CtryInfo.DateSeparator;
  718. case CtryInfo.DateFormat of
  719. 1: begin
  720. ShortDateFormat := 'd/m/y';
  721. LongDateFormat := 'dd" "mmmm" "yyyy';
  722. end;
  723. 2: begin
  724. ShortDateFormat := 'y/m/d';
  725. LongDateFormat := 'yyyy" "mmmm" "dd';
  726. end;
  727. 3: begin
  728. ShortDateFormat := 'm/d/y';
  729. LongDateFormat := 'mmmm" "dd" "yyyy';
  730. end;
  731. end;
  732. TimeSeparator := CtryInfo.TimeSeparator;
  733. DecimalSeparator := CtryInfo.DecimalSeparator;
  734. ThousandSeparator := CtryInfo.ThousandSeparator;
  735. CurrencyFormat := CtryInfo.CurrencyFormat;
  736. CurrencyString := PChar (CtryInfo.CurrencyUnit);
  737. end;
  738. InitAnsi;
  739. InitInternationalGeneric;
  740. end;
  741. function SysErrorMessage(ErrorCode: Integer): String;
  742. begin
  743. Result:=Format(SUnknownErrorCode,[ErrorCode]);
  744. end;
  745. {****************************************************************************
  746. OS Utils
  747. ****************************************************************************}
  748. Function GetEnvironmentVariable(Const EnvVar : String) : String;
  749. begin
  750. GetEnvironmentVariable := StrPas (GetEnvPChar (EnvVar));
  751. end;
  752. Function GetEnvironmentVariableCount : Integer;
  753. begin
  754. (* Result:=FPCCountEnvVar(EnvP); - the amount is already known... *)
  755. GetEnvironmentVariableCount := EnvC;
  756. end;
  757. Function GetEnvironmentString(Index : Integer) : String;
  758. begin
  759. Result:=FPCGetEnvStrFromP (EnvP, Index);
  760. end;
  761. procedure Sleep (Milliseconds: cardinal);
  762. begin
  763. DosSleep (Milliseconds);
  764. end;
  765. function ExecuteProcess (const Path: AnsiString; const ComLine: AnsiString):
  766. integer;
  767. var
  768. HQ: THandle;
  769. SPID, STID, QName: shortstring;
  770. SD: TStartData;
  771. SID, PID: cardinal;
  772. RD: TRequestData;
  773. PCI: PChildInfo;
  774. CISize: cardinal;
  775. Prio: byte;
  776. E: EOSError;
  777. CommandLine: ansistring;
  778. Args0, Args: PByteArray;
  779. ObjNameBuf: PChar;
  780. ArgSize: word;
  781. Res: TResultCodes;
  782. ObjName: shortstring;
  783. const
  784. MaxArgsSize = 3072; (* Amount of memory reserved for arguments in bytes. *)
  785. ObjBufSize = 512;
  786. begin
  787. ObjName := '';
  788. GetMem (ObjNameBuf, ObjBufSize);
  789. FillChar (ObjNameBuf^, ObjBufSize, 0);
  790. if ComLine = '' then
  791. begin
  792. Args0 := nil;
  793. Args := nil;
  794. end
  795. else
  796. begin
  797. GetMem (Args0, MaxArgsSize);
  798. Args := Args0;
  799. (* Work around a bug in OS/2 - argument to DosExecPgm *)
  800. (* should not cross 64K boundary. *)
  801. if ((PtrUInt (Args) + 1024) and $FFFF) < 1024 then
  802. Inc (pointer (Args), 1024);
  803. ArgSize := 0;
  804. Move (Path [1], Args^ [ArgSize], Length (Path));
  805. Inc (ArgSize, Length (Path));
  806. Args^ [ArgSize] := 0;
  807. Inc (ArgSize);
  808. {Now do the real arguments.}
  809. Move (ComLine [1], Args^ [ArgSize], Length (ComLine));
  810. Inc (ArgSize, Length (ComLine));
  811. Args^ [ArgSize] := 0;
  812. Inc (ArgSize);
  813. Args^ [ArgSize] := 0;
  814. end;
  815. Result := DosExecPgm (ObjNameBuf, ObjBufSize, 0, Args, nil, Res, PChar (Path));
  816. if Args0 <> nil then
  817. FreeMem (Args0, MaxArgsSize);
  818. if Result = 0 then
  819. begin
  820. Result := Res.ExitCode;
  821. FreeMem (ObjNameBuf, ObjBufSize);
  822. end
  823. else
  824. begin
  825. if (Result = 190) or (Result = 191) then
  826. begin
  827. FillChar (SD, SizeOf (SD), 0);
  828. SD.Length := 24;
  829. SD.Related := ssf_Related_Child;
  830. CommandLine := FExpand (Path); (* Needed for other session types... *)
  831. SD.PgmName := PChar (CommandLine);
  832. if ComLine <> '' then
  833. SD.PgmInputs := PChar (ComLine);
  834. SD.InheritOpt := ssf_InhertOpt_Parent;
  835. Str (GetProcessID, SPID);
  836. Str (ThreadID, STID);
  837. QName := '\QUEUES\FPC_ExecuteProcess_p' + SPID + 't' + STID + '.QUE'#0;
  838. SD.TermQ := @QName [1];
  839. Result := DosCreateQueue (HQ, quFIFO or quConvert_Address, @QName [1]);
  840. if Result = 0 then
  841. begin
  842. Result := DosStartSession (SD, SID, PID);
  843. if (Result = 0) or (Result = 457) then
  844. begin
  845. Result := DosReadQueue (HQ, RD, CISize, PCI, 0, 0, Prio, 0);
  846. if Result = 0 then
  847. begin
  848. Result := PCI^.Return;
  849. DosCloseQueue (HQ);
  850. DosFreeMem (PCI);
  851. Exit;
  852. end;
  853. end;
  854. DosCloseQueue (HQ);
  855. end;
  856. end
  857. else
  858. ObjName := StrPas (ObjNameBuf);
  859. FreeMem (ObjNameBuf, ObjBufSize);
  860. if ComLine = '' then
  861. CommandLine := Path
  862. else
  863. CommandLine := Path + ' ' + ComLine;
  864. if ObjName = '' then
  865. E := EOSError.CreateFmt (SExecuteProcessFailed, [CommandLine, Result])
  866. else
  867. E := EOSError.CreateFmt (SExecuteProcessFailed + '(' + ObjName + ')', [CommandLine, Result]);
  868. E.ErrorCode := Result;
  869. raise E;
  870. end;
  871. end;
  872. function ExecuteProcess (const Path: AnsiString;
  873. const ComLine: array of AnsiString): integer;
  874. var
  875. CommandLine: AnsiString;
  876. I: integer;
  877. begin
  878. Commandline := '';
  879. for I := 0 to High (ComLine) do
  880. if Pos (' ', ComLine [I]) <> 0 then
  881. CommandLine := CommandLine + ' ' + '"' + ComLine [I] + '"'
  882. else
  883. CommandLine := CommandLine + ' ' + Comline [I];
  884. ExecuteProcess := ExecuteProcess (Path, CommandLine);
  885. end;
  886. {****************************************************************************
  887. Initialization code
  888. ****************************************************************************}
  889. Initialization
  890. InitExceptions; { Initialize exceptions. OS independent }
  891. InitInternational; { Initialize internationalization settings }
  892. Finalization
  893. DoneExceptions;
  894. end.