sysutils.pp 39 KB

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