2
0

sysutils.pp 51 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874
  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 linux
  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. {$modeswitch typehelpers}
  19. {$modeswitch advancedrecords}
  20. {$if (defined(BSD) or defined(SUNOS)) and defined(FPC_USE_LIBC)}
  21. {$define USE_VFORK}
  22. {$endif}
  23. {$DEFINE OS_FILESETDATEBYNAME}
  24. {$DEFINE HAS_SLEEP}
  25. {$DEFINE HAS_OSERROR}
  26. {$DEFINE HAS_OSCONFIG}
  27. {$DEFINE HAS_TEMPDIR}
  28. {$DEFINE HASUNIX}
  29. {$DEFINE HASCREATEGUID}
  30. {$DEFINE HAS_OSUSERDIR}
  31. {$DEFINE HAS_LOCALTIMEZONEOFFSET}
  32. {$DEFINE HAS_GETTICKCOUNT64}
  33. // this target has an fileflush implementation, don't include dummy
  34. {$DEFINE SYSUTILS_HAS_FILEFLUSH_IMPL}
  35. { used OS file system APIs use ansistring }
  36. {$define SYSUTILS_HAS_ANSISTR_FILEUTIL_IMPL}
  37. { OS has an ansistring/single byte environment variable API }
  38. {$define SYSUTILS_HAS_ANSISTR_ENVVAR_IMPL}
  39. uses
  40. {$IFDEF LINUX}linux,{$ENDIF}
  41. {$IFDEF FreeBSD}freebsd,{$ENDIF}
  42. Unix,errors,sysconst,Unixtype;
  43. {$IF defined(LINUX) or defined(FreeBSD)}
  44. {$DEFINE HAVECLOCKGETTIME}
  45. {$ENDIF}
  46. {$IF defined(DARWIN)}
  47. {$DEFINE HAS_ISFILENAMECASEPRESERVING}
  48. {$DEFINE HAS_ISFILENAMECASESENSITIVE}
  49. {$ENDIF}
  50. {$if defined(LINUX)}
  51. {$if sizeof(clong)<8}
  52. {$DEFINE USE_STATX}
  53. {$DEFINE USE_UTIMENSAT}
  54. {$endif sizeof(clong)<=4}
  55. {$DEFINE USE_FUTIMES}
  56. {$endif}
  57. { Include platform independent interface part }
  58. {$i sysutilh.inc}
  59. Function AddDisk(const path:string) : Byte;
  60. { the following is Kylix compatibility stuff, it should be moved to a
  61. special compatibilty unit (FK) }
  62. const
  63. RTL_SIGINT = 0;
  64. RTL_SIGFPE = 1;
  65. RTL_SIGSEGV = 2;
  66. RTL_SIGILL = 3;
  67. RTL_SIGBUS = 4;
  68. RTL_SIGQUIT = 5;
  69. RTL_SIGLAST = RTL_SIGQUIT;
  70. RTL_SIGDEFAULT = -1;
  71. type
  72. TSignalState = (ssNotHooked, ssHooked, ssOverridden);
  73. function InquireSignal(RtlSigNum: Integer): TSignalState;
  74. procedure AbandonSignalHandler(RtlSigNum: Integer);
  75. procedure HookSignal(RtlSigNum: Integer);
  76. procedure UnhookSignal(RtlSigNum: Integer; OnlyIfHooked: Boolean = True);
  77. implementation
  78. Uses
  79. {$ifdef android}
  80. dl,
  81. {$endif android}
  82. {$ifdef FPC_USE_LIBC}initc{$ELSE}Syscall{$ENDIF}, Baseunix, unixutil;
  83. type
  84. tsiginfo = record
  85. oldsiginfo: sigactionrec;
  86. hooked: boolean;
  87. end;
  88. const
  89. rtlsig2ossig: array[RTL_SIGINT..RTL_SIGLAST] of byte =
  90. (SIGINT,SIGFPE,SIGSEGV,SIGILL,SIGBUS,SIGQUIT);
  91. { to avoid linking in all this stuff in every program,
  92. as it's unlikely to be used by anything but libraries
  93. }
  94. signalinfoinited: boolean = false;
  95. var
  96. siginfo: array[RTL_SIGINT..RTL_SIGLAST] of tsiginfo;
  97. oldsigfpe: SigActionRec; external name '_FPC_OLDSIGFPE';
  98. oldsigsegv: SigActionRec; external name '_FPC_OLDSIGSEGV';
  99. oldsigbus: SigActionRec; external name '_FPC_OLDSIGBUS';
  100. oldsigill: SigActionRec; external name '_FPC_OLDSIGILL';
  101. procedure defaultsighandler; external name '_FPC_DEFAULTSIGHANDLER';
  102. procedure installdefaultsignalhandler(signum: Integer; out oldact: SigActionRec); external name '_FPC_INSTALLDEFAULTSIGHANDLER';
  103. function InternalInquireSignal(RtlSigNum: Integer; out act: SigActionRec; frominit: boolean): TSignalState;
  104. begin
  105. result:=ssNotHooked;
  106. if (RtlSigNum<>RTL_SIGDEFAULT) and
  107. (RtlSigNum<RTL_SIGLAST) then
  108. begin
  109. if (frominit or
  110. siginfo[RtlSigNum].hooked) and
  111. (fpsigaction(rtlsig2ossig[RtlSigNum],nil,@act)=0) then
  112. begin
  113. if not frominit then
  114. begin
  115. { check whether the installed signal handler is still ours }
  116. {$if not defined(aix) and (not defined(linux) or not defined(cpupowerpc64) or (defined(_call_elf) and (_call_elf = 2)))}
  117. if (pointer(act.sa_handler)=pointer(@defaultsighandler)) then
  118. {$else}
  119. { on aix and linux/ppc64 (ELFv1), procedure addresses are
  120. actually descriptors -> check whether the code addresses
  121. inside the descriptors match, rather than the descriptors
  122. themselves }
  123. if (ppointer(act.sa_handler)^=ppointer(@defaultsighandler)^) then
  124. {$endif}
  125. result:=ssHooked
  126. else
  127. result:=ssOverridden;
  128. end
  129. else if IsLibrary then
  130. begin
  131. { library -> signals have not been hooked by system init code }
  132. exit
  133. end
  134. else
  135. begin
  136. { program -> signals have been hooked by system init code }
  137. if (byte(RtlSigNum) in [RTL_SIGFPE,RTL_SIGSEGV,RTL_SIGILL,RTL_SIGBUS]) then
  138. begin
  139. {$if not defined(aix) and (not defined(linux) or not defined(cpupowerpc64) or (defined(_call_elf) and (_call_elf = 2)))}
  140. if (pointer(act.sa_handler)=pointer(@defaultsighandler)) then
  141. {$else}
  142. if (ppointer(act.sa_handler)^=ppointer(@defaultsighandler)^) then
  143. {$endif}
  144. result:=ssHooked
  145. else
  146. result:=ssOverridden;
  147. { return the original handlers as saved by the system unit
  148. (the current call to sigaction simply returned our
  149. system unit's installed handlers)
  150. }
  151. case RtlSigNum of
  152. RTL_SIGFPE:
  153. act:=oldsigfpe;
  154. RTL_SIGSEGV:
  155. act:=oldsigsegv;
  156. RTL_SIGILL:
  157. act:=oldsigill;
  158. RTL_SIGBUS:
  159. act:=oldsigbus;
  160. end;
  161. end
  162. else
  163. begin
  164. { these are not hooked in the startup code }
  165. result:=ssNotHooked;
  166. end
  167. end
  168. end
  169. end;
  170. end;
  171. procedure initsignalinfo;
  172. var
  173. i: Integer;
  174. begin
  175. for i:=RTL_SIGINT to RTL_SIGLAST do
  176. siginfo[i].hooked:=(InternalInquireSignal(i,siginfo[i].oldsiginfo,true)=ssHooked);
  177. signalinfoinited:=true;
  178. end;
  179. function InquireSignal(RtlSigNum: Integer): TSignalState;
  180. var
  181. act: SigActionRec;
  182. begin
  183. if not signalinfoinited then
  184. initsignalinfo;
  185. result:=InternalInquireSignal(RtlSigNum,act,false);
  186. end;
  187. procedure AbandonSignalHandler(RtlSigNum: Integer);
  188. begin
  189. if not signalinfoinited then
  190. initsignalinfo;
  191. if (RtlSigNum<>RTL_SIGDEFAULT) and
  192. (RtlSigNum<RTL_SIGLAST) then
  193. siginfo[RtlSigNum].hooked:=false;
  194. end;
  195. procedure HookSignal(RtlSigNum: Integer);
  196. var
  197. lowsig, highsig, i: Integer;
  198. begin
  199. if not signalinfoinited then
  200. initsignalinfo;
  201. if (RtlSigNum<>RTL_SIGDEFAULT) then
  202. begin
  203. lowsig:=RtlSigNum;
  204. highsig:=RtlSigNum;
  205. end
  206. else
  207. begin
  208. { we don't hook SIGINT and SIGQUIT by default }
  209. lowsig:=RTL_SIGFPE;
  210. highsig:=RTL_SIGBUS;
  211. end;
  212. { install the default rtl signal handler for the selected signal(s) }
  213. for i:=lowsig to highsig do
  214. begin
  215. installdefaultsignalhandler(rtlsig2ossig[i],siginfo[i].oldsiginfo);
  216. siginfo[i].hooked:=true;
  217. end;
  218. end;
  219. procedure UnhookSignal(RtlSigNum: Integer; OnlyIfHooked: Boolean = True);
  220. var
  221. act: SigActionRec;
  222. lowsig, highsig, i: Integer;
  223. begin
  224. if not signalinfoinited then
  225. initsignalinfo;
  226. if (RtlSigNum<>RTL_SIGDEFAULT) then
  227. begin
  228. lowsig:=RtlSigNum;
  229. highsig:=RtlSigNum;
  230. end
  231. else
  232. begin
  233. { we don't hook SIGINT and SIGQUIT by default }
  234. lowsig:=RTL_SIGFPE;
  235. highsig:=RTL_SIGBUS;
  236. end;
  237. for i:=lowsig to highsig do
  238. begin
  239. if not OnlyIfHooked or
  240. (InquireSignal(i)=ssHooked) then
  241. begin
  242. { restore the handler that was present when we hooked the signal,
  243. if we hooked it at one time or another. If the user doesn't
  244. want this, they have to call AbandonSignalHandler() first
  245. }
  246. if siginfo[i].hooked then
  247. act:=siginfo[i].oldsiginfo
  248. else
  249. begin
  250. fillchar(act,sizeof(act),0);
  251. pointer(act.sa_handler):=pointer(SIG_DFL);
  252. end;
  253. if (fpsigaction(rtlsig2ossig[i],@act,nil)=0) then
  254. siginfo[i].hooked:=false;
  255. end;
  256. end;
  257. end;
  258. {$Define OS_FILEISREADONLY} // Specific implementation for Unix.
  259. {$DEFINE FPC_FEXPAND_TILDE} { Tilde is expanded to home }
  260. {$DEFINE FPC_FEXPAND_GETENVPCHAR} { GetEnv result is a PChar }
  261. { Include platform independent implementation part }
  262. {$define executeprocuni}
  263. {$i sysutils.inc}
  264. { Include SysCreateGUID function }
  265. {$i suuid.inc}
  266. function GetTickCount64: QWord;
  267. var
  268. tp: TTimeVal;
  269. {$IFDEF HAVECLOCKGETTIME}
  270. ts: TTimeSpec;
  271. {$ENDIF}
  272. begin
  273. {$IFDEF HAVECLOCKGETTIME}
  274. if clock_gettime(CLOCK_MONOTONIC, @ts)=0 then
  275. begin
  276. Result := (Int64(ts.tv_sec) * 1000) + (ts.tv_nsec div 1000000);
  277. exit;
  278. end;
  279. {$ENDIF}
  280. fpgettimeofday(@tp, nil);
  281. Result := (Int64(tp.tv_sec) * 1000) + (tp.tv_usec div 1000);
  282. end;
  283. {****************************************************************************
  284. File Functions
  285. ****************************************************************************}
  286. Function DoFileLocking(Handle: Longint; Mode: Integer) : Longint;
  287. var
  288. lockop: cint;
  289. lockres: cint;
  290. closeres: cint;
  291. lockerr: cint;
  292. begin
  293. DoFileLocking:=Handle;
  294. {$ifdef beos}
  295. {$else}
  296. if (Handle>=0) then
  297. begin
  298. {$if defined(solaris) or defined(aix)}
  299. { Solaris' & AIX' flock is based on top of fcntl, which does not allow
  300. exclusive locks for files only opened for reading nor shared locks
  301. for files opened only for writing.
  302. If no locking is specified, we normally need an exclusive lock.
  303. So create an exclusive lock for fmOpenWrite and fmOpenReadWrite,
  304. but only a shared lock for fmOpenRead (since an exclusive lock
  305. is not possible in that case)
  306. }
  307. if ((mode and (fmShareCompat or fmShareExclusive or fmShareDenyWrite or fmShareDenyRead or fmShareDenyNone)) = 0) then
  308. begin
  309. if ((mode and (fmOpenRead or fmOpenWrite or fmOpenReadWrite)) = fmOpenRead) then
  310. mode := mode or fmShareDenyWrite
  311. else
  312. mode := mode or fmShareExclusive;
  313. end;
  314. {$endif solaris}
  315. case (mode and (fmShareCompat or fmShareExclusive or fmShareDenyWrite or fmShareDenyRead or fmShareDenyNone)) of
  316. fmShareCompat,
  317. fmShareExclusive:
  318. lockop:=LOCK_EX or LOCK_NB;
  319. fmShareDenyWrite,
  320. fmShareDenyNone:
  321. lockop:=LOCK_SH or LOCK_NB;
  322. else
  323. begin
  324. { fmShareDenyRead does not exit under *nix, only shared access
  325. (similar to fmShareDenyWrite) and exclusive access (same as
  326. fmShareExclusive)
  327. }
  328. repeat
  329. closeres:=FpClose(Handle);
  330. until (closeres<>-1) or (fpgeterrno<>ESysEINTR);
  331. DoFileLocking:=-1;
  332. exit;
  333. end;
  334. end;
  335. repeat
  336. lockres:=fpflock(Handle,lockop);
  337. until (lockres=0) or
  338. (fpgeterrno<>ESysEIntr);
  339. lockerr:=fpgeterrno;
  340. { Only return an error if locks are working and the file was already
  341. locked. Not if locks are simply unsupported (e.g., on Angstrom Linux
  342. you always get ESysNOLCK in the default configuration) }
  343. if (lockres<>0) and
  344. ((lockerr=ESysEAGAIN) or
  345. (lockerr=EsysEDEADLK)) then
  346. begin
  347. repeat
  348. closeres:=FpClose(Handle);
  349. until (closeres<>-1) or (fpgeterrno<>ESysEINTR);
  350. DoFileLocking:=-1;
  351. exit;
  352. end;
  353. end;
  354. {$endif not beos}
  355. end;
  356. Function FileOpenNoLocking (Const FileName : RawbyteString; Mode : Integer) : Longint;
  357. Function IsHandleDirectory(Handle : Longint) : boolean;
  358. Var Info : Stat;
  359. begin
  360. Result := (fpFStat(Handle, Info)<0) or fpS_ISDIR(info.st_mode);
  361. end;
  362. Var
  363. SystemFileName: RawByteString;
  364. fd,LinuxFlags : longint;
  365. begin
  366. LinuxFlags:=0;
  367. case (Mode and (fmOpenRead or fmOpenWrite or fmOpenReadWrite)) of
  368. fmOpenRead : LinuxFlags:=LinuxFlags or O_RdOnly;
  369. fmOpenWrite : LinuxFlags:=LinuxFlags or O_WrOnly;
  370. fmOpenReadWrite : LinuxFlags:=LinuxFlags or O_RdWr;
  371. end;
  372. SystemFileName:=ToSingleByteFileSystemEncodedFileName(FileName);
  373. repeat
  374. fd:=fpOpen (pointer(SystemFileName),LinuxFlags);
  375. until (fd<>-1) or (fpgeterrno<>ESysEINTR);
  376. { Do not allow to open directories with FileOpen.
  377. This would cause weird behavior of TFileStream.Size,
  378. TMemoryStream.LoadFromFile etc. }
  379. if (fd<>-1) and IsHandleDirectory(fd) then
  380. begin
  381. fpClose(fd);
  382. fd:=feInvalidHandle;
  383. end;
  384. FileOpenNoLocking:=fd;
  385. end;
  386. Function FileOpen (Const FileName : RawbyteString; Mode : Integer) : Longint;
  387. begin
  388. FileOpen:=FileOpenNoLocking(FileName, Mode);
  389. FileOpen:=DoFileLocking(FileOpen, Mode);
  390. end;
  391. function FileFlush(Handle: THandle): Boolean;
  392. begin
  393. Result:= fpfsync(handle)=0;
  394. end;
  395. Function FileCreate (Const FileName : RawByteString) : Longint;
  396. Var
  397. SystemFileName: RawByteString;
  398. begin
  399. SystemFileName:=ToSingleByteFileSystemEncodedFileName(FileName);
  400. repeat
  401. FileCreate:=fpOpen(pointer(SystemFileName),O_RdWr or O_Creat or O_Trunc);
  402. until (FileCreate<>-1) or (fpgeterrno<>ESysEINTR);
  403. end;
  404. Function FileCreate (Const FileName : RawByteString;Rights : Longint) : Longint;
  405. Var
  406. SystemFileName: RawByteString;
  407. begin
  408. SystemFileName:=ToSingleByteFileSystemEncodedFileName(FileName);
  409. repeat
  410. FileCreate:=fpOpen(pointer(SystemFileName),O_RdWr or O_Creat or O_Trunc,Rights);
  411. until (FileCreate<>-1) or (fpgeterrno<>ESysEINTR);
  412. end;
  413. Function FileCreate (Const FileName : RawByteString; ShareMode : Longint; Rights:LongInt ) : Longint;
  414. Var
  415. fd: Longint;
  416. begin
  417. { if the file already exists and we can't open it using the requested
  418. ShareMode (e.g. exclusive sharing), exit immediately so that we don't
  419. first empty the file and then check whether we can lock this new file
  420. (which we can by definition) }
  421. fd:=FileOpenNoLocking(FileName,ShareMode);
  422. { the file exists, check whether our locking request is compatible }
  423. if fd>=0 then
  424. begin
  425. Result:=DoFileLocking(fd,ShareMode);
  426. FileClose(fd);
  427. { Can't lock -> abort }
  428. if Result<0 then
  429. exit;
  430. end;
  431. { now create the file }
  432. Result:=FileCreate(FileName,Rights);
  433. Result:=DoFileLocking(Result,ShareMode);
  434. end;
  435. Function FileRead (Handle : Longint; out Buffer; Count : longint) : Longint;
  436. begin
  437. repeat
  438. FileRead:=fpRead (Handle,Buffer,Count);
  439. until (FileRead<>-1) or (fpgeterrno<>ESysEINTR);
  440. end;
  441. Function FileWrite (Handle : Longint; const Buffer; Count : Longint) : Longint;
  442. begin
  443. repeat
  444. FileWrite:=fpWrite (Handle,Buffer,Count);
  445. until (FileWrite<>-1) or (fpgeterrno<>ESysEINTR);
  446. end;
  447. Function FileSeek (Handle,FOffset,Origin : Longint) : Longint;
  448. Var
  449. I : Int64;
  450. begin
  451. I:=FileSeek(Handle,int64(FOffset),Origin);
  452. if I>High(Longint) then
  453. Raise EInOutError.CreateFmt(SErrPosToBigForLongint,[I]);
  454. result:=I;
  455. end;
  456. Function FileSeek (Handle : Longint; FOffset : Int64; Origin : Longint) : Int64;
  457. begin
  458. FileSeek:=fplSeek (Handle,FOffset,Origin);
  459. end;
  460. Procedure FileClose (Handle : Longint);
  461. var
  462. res: cint;
  463. begin
  464. repeat
  465. res:=fpclose(Handle);
  466. until (res<>-1) or (fpgeterrno<>ESysEINTR);
  467. end;
  468. Function FileTruncate (Handle: THandle; Size: Int64) : boolean;
  469. var
  470. res: cint;
  471. begin
  472. if (SizeOf (TOff) < 8) (* fpFTruncate only supporting signed 32-bit size *)
  473. and (Size > high (longint)) then
  474. FileTruncate := false
  475. else
  476. begin
  477. repeat
  478. res:=fpftruncate(Handle,Size);
  479. until (res<>-1) or (fpgeterrno<>ESysEINTR);
  480. FileTruncate:=res>=0;
  481. end;
  482. end;
  483. Function FileAge (Const FileName : RawByteString): Int64;
  484. Var
  485. Info : Stat;
  486. SystemFileName: RawByteString;
  487. {$ifdef USE_STATX}
  488. Infox : TStatx;
  489. {$endif USE_STATX}
  490. begin
  491. SystemFileName:=ToSingleByteFileSystemEncodedFileName(FileName);
  492. {$ifdef USE_STATX}
  493. { first try statx }
  494. if (statx(AT_FDCWD,pchar(SystemFileName),0,STATX_MTIME or STATX_MODE,Infox)>=0) and not(fpS_ISDIR(Infox.stx_mode)) then
  495. begin
  496. Result:=Infox.stx_mtime.tv_sec;
  497. exit;
  498. end;
  499. {$endif USE_STATX}
  500. If (fpstat(pchar(SystemFileName),Info)<0) or fpS_ISDIR(info.st_mode) then
  501. exit(-1)
  502. else
  503. Result:=info.st_mtime;
  504. end;
  505. Function LinuxToWinAttr (const FN : RawByteString; Const Info : Stat) : Longint;
  506. Var
  507. LinkInfo : Stat;
  508. nm : RawByteString;
  509. begin
  510. Result:=faArchive;
  511. If fpS_ISDIR(Info.st_mode) then
  512. Result:=Result or faDirectory;
  513. nm:=ExtractFileName(FN);
  514. If (Length(nm)>=2) and
  515. (nm[1]='.') and
  516. (nm[2]<>'.') then
  517. Result:=Result or faHidden;
  518. If (Info.st_Mode and S_IWUSR)=0 Then
  519. Result:=Result or faReadOnly;
  520. If fpS_ISSOCK(Info.st_mode) or fpS_ISBLK(Info.st_mode) or fpS_ISCHR(Info.st_mode) or fpS_ISFIFO(Info.st_mode) Then
  521. Result:=Result or faSysFile;
  522. If fpS_ISLNK(Info.st_mode) Then
  523. begin
  524. Result:=Result or faSymLink;
  525. // Windows reports if the link points to a directory.
  526. if (fpstat(pchar(FN),LinkInfo)>=0) and fpS_ISDIR(LinkInfo.st_mode) then
  527. Result := Result or faDirectory;
  528. end;
  529. end;
  530. {$ifdef USE_STATX}
  531. Function LinuxToWinAttr (const FN : RawByteString; Const Info : TStatx) : Longint;
  532. Var
  533. LinkInfo : Stat;
  534. nm : RawByteString;
  535. begin
  536. Result:=faArchive;
  537. If fpS_ISDIR(Info.stx_mode) then
  538. Result:=Result or faDirectory;
  539. nm:=ExtractFileName(FN);
  540. If (Length(nm)>=2) and
  541. (nm[1]='.') and
  542. (nm[2]<>'.') then
  543. Result:=Result or faHidden;
  544. If (Info.stx_Mode and S_IWUSR)=0 Then
  545. Result:=Result or faReadOnly;
  546. If fpS_ISSOCK(Info.stx_mode) or fpS_ISBLK(Info.stx_mode) or fpS_ISCHR(Info.stx_mode) or fpS_ISFIFO(Info.stx_mode) Then
  547. Result:=Result or faSysFile;
  548. If fpS_ISLNK(Info.stx_mode) Then
  549. begin
  550. Result:=Result or faSymLink;
  551. // Windows reports if the link points to a directory.
  552. { as we are only interested in the st_mode field here, we do not need to use statx }
  553. if (fpstat(pchar(FN),LinkInfo)>=0) and fpS_ISDIR(LinkInfo.st_mode) then
  554. Result := Result or faDirectory;
  555. end;
  556. end;
  557. {$endif USE_STATX}
  558. function FileGetSymLinkTarget(const FileName: RawByteString; out SymLinkRec: TRawbyteSymLinkRec): Boolean;
  559. var
  560. Info : Stat;
  561. SystemFileName: RawByteString;
  562. begin
  563. SystemFileName:=ToSingleByteFileSystemEncodedFileName(FileName);
  564. if (fplstat(SystemFileName,Info)>=0) and fpS_ISLNK(Info.st_mode) then begin
  565. FillByte(SymLinkRec, SizeOf(SymLinkRec), 0);
  566. SymLinkRec.TargetName:=fpreadlink(SystemFileName);
  567. if fpstat(pointer(SystemFileName), Info) < 0 then
  568. raise EDirectoryNotFoundException.Create(SysErrorMessage(GetLastOSError));
  569. SymLinkRec.Attr := LinuxToWinAttr(SystemFileName, Info);
  570. SymLinkRec.Size := Info.st_size;
  571. SymLinkRec.Mode := Info.st_mode;
  572. Result:=True;
  573. end else
  574. Result:=False;
  575. end;
  576. Function FileExists (Const FileName : RawByteString; FollowLink : Boolean) : Boolean;
  577. var
  578. Info : Stat;
  579. SystemFileName: RawByteString;
  580. isdir: Boolean;
  581. begin
  582. // Do not call fpAccess with an empty name. (Valgrind will complain)
  583. if Filename='' then
  584. Exit(False);
  585. SystemFileName:=ToSingleByteFileSystemEncodedFileName(FileName);
  586. // Don't use stat. It fails on files >2 GB.
  587. // Access obeys the same access rules, so the result should be the same.
  588. FileExists:=fpAccess(pointer(SystemFileName),F_OK)=0;
  589. { we need to ensure however that we aren't dealing with a directory }
  590. isdir:=False;
  591. if FileExists then begin
  592. if (fpstat(pointer(SystemFileName),Info)>=0) and fpS_ISDIR(Info.st_mode) then begin
  593. FileExists:=False;
  594. isdir:=True;
  595. end;
  596. end;
  597. { if we shall not follow the link we only need to check for a symlink if the
  598. target file itself should not exist }
  599. if not FileExists and not isdir and not FollowLink then
  600. FileExists:=(fplstat(pointer(SystemFileName),Info)>=0) and fpS_ISLNK(Info.st_mode);
  601. end;
  602. Function DirectoryExists (Const Directory : RawByteString; FollowLink : Boolean) : Boolean;
  603. Var
  604. Info : Stat;
  605. SystemFileName: RawByteString;
  606. exists: Boolean;
  607. begin
  608. SystemFileName:=ToSingleByteFileSystemEncodedFileName(Directory);
  609. exists:=fpstat(pointer(SystemFileName),Info)>=0;
  610. DirectoryExists:=exists and fpS_ISDIR(Info.st_mode);
  611. { if we shall not follow the link we only need to check for a symlink if the
  612. target directory itself should not exist }
  613. if not exists and not FollowLink then
  614. DirectoryExists:=(fplstat(pointer(SystemFileName),Info)>=0) and fpS_ISLNK(Info.st_mode);
  615. end;
  616. { assumes that pattern and name have the same code page }
  617. Function FNMatch(const Pattern,Name:string):Boolean;
  618. Var
  619. LenPat,LenName : longint;
  620. function NameUtf8CodePointLen(index: longint): longint;
  621. var
  622. MaxLookAhead: longint;
  623. begin
  624. MaxLookAhead:=LenName-Index+1;
  625. { abs so that in case of an invalid sequence, we count this as one
  626. codepoint }
  627. NameUtf8CodePointLen:=abs(Utf8CodePointLen(pansichar(@Name[index]),MaxLookAhead,true));
  628. { if the sequence was incomplete, use the incomplete sequence as
  629. codepoint }
  630. if NameUtf8CodePointLen=0 then
  631. NameUtf8CodePointLen:=MaxLookAhead;
  632. end;
  633. procedure GoToLastByteOfUtf8CodePoint(var j: longint);
  634. begin
  635. inc(j,NameUtf8CodePointLen(j)-1);
  636. end;
  637. { input:
  638. i: current position in pattern (start of utf-8 code point)
  639. j: current position in name (start of utf-8 code point)
  640. update_i_j: should i and j be changed by the routine or not
  641. output:
  642. i: if update_i_j, then position of last matching part of code point in
  643. pattern, or first non-matching code point in pattern. Otherwise the
  644. same value as on input.
  645. j: if update_i_j, then position of last matching part of code point in
  646. name, or first non-matching code point in name. Otherwise the
  647. same value as on input.
  648. result: true if match, false if no match
  649. }
  650. function CompareUtf8CodePoint(var i,j: longint; update_i_j: boolean): Boolean;
  651. var
  652. bytes,
  653. new_i,
  654. new_j: longint;
  655. begin
  656. bytes:=NameUtf8CodePointLen(j);
  657. new_i:=i;
  658. new_j:=j;
  659. { ensure that a part of an UTF-8 codepoint isn't interpreted
  660. as '*' or '?' }
  661. repeat
  662. dec(bytes);
  663. Result:=
  664. (new_j<=LenName) and
  665. (new_i<=LenPat) and
  666. (Pattern[new_i]=Name[new_j]);
  667. inc(new_i);
  668. inc(new_j);
  669. until not(Result) or
  670. (bytes=0);
  671. if update_i_j then
  672. begin
  673. i:=new_i;
  674. j:=new_j;
  675. end;
  676. end;
  677. Function DoFNMatch(i,j:longint):Boolean;
  678. Var
  679. UTF8, Found : boolean;
  680. Begin
  681. Found:=true;
  682. { ensure that we don't skip partial characters in UTF-8-encoded strings }
  683. UTF8:=StringCodePage(Name)=CP_UTF8;
  684. While Found and (i<=LenPat) Do
  685. Begin
  686. Case Pattern[i] of
  687. '?' :
  688. begin
  689. Found:=(j<=LenName);
  690. if UTF8 then
  691. GoToLastByteOfUtf8CodePoint(j);
  692. end;
  693. '*' : Begin
  694. {find the next character in pattern, different of ? and *}
  695. while Found do
  696. begin
  697. inc(i);
  698. if i>LenPat then
  699. Break;
  700. case Pattern[i] of
  701. '*' : ;
  702. '?' : begin
  703. if j>LenName then
  704. begin
  705. DoFNMatch:=false;
  706. Exit;
  707. end;
  708. if UTF8 then
  709. GoToLastByteOfUtf8CodePoint(j);
  710. inc(j);
  711. end;
  712. else
  713. Found:=false;
  714. end;
  715. end;
  716. Assert((i>LenPat) or ( (Pattern[i]<>'*') and (Pattern[i]<>'?') ));
  717. { Now, find in name the character which i points to, if the * or
  718. ? wasn't the last character in the pattern, else, use up all
  719. the chars in name }
  720. Found:=false;
  721. if (i<=LenPat) then
  722. begin
  723. repeat
  724. {find a letter (not only first !) which maches pattern[i]}
  725. if UTF8 then
  726. begin
  727. while (j<=LenName) and
  728. ((name[j]<>pattern[i]) or
  729. not CompareUtf8CodePoint(i,j,false)) do
  730. begin
  731. GoToLastByteOfUtf8CodePoint(j);
  732. inc(j);
  733. end;
  734. end
  735. else
  736. begin
  737. while (j<=LenName) and (name[j]<>pattern[i]) do
  738. inc (j);
  739. end;
  740. if (j<LenName) then
  741. begin
  742. { while positions i/j have already been checked, in
  743. case of UTF-8 we have to ensure that we don't split
  744. a code point. Otherwise we can skip over comparing
  745. the same characters twice }
  746. if DoFnMatch(i+ord(not UTF8),j+ord(not UTF8)) then
  747. begin
  748. i:=LenPat;
  749. j:=LenName;{we can stop}
  750. Found:=true;
  751. Break;
  752. end
  753. { We didn't find one, need to look further }
  754. else
  755. begin
  756. if UTF8 then
  757. GoToLastByteOfUtf8CodePoint(j);
  758. inc(j);
  759. end;
  760. end
  761. else if j=LenName then
  762. begin
  763. Found:=true;
  764. Break;
  765. end;
  766. { This 'until' condition must be j>LenName, not j>=LenName.
  767. That's because when we 'need to look further' and
  768. j = LenName then loop must not terminate. }
  769. until (j>LenName);
  770. end
  771. else
  772. begin
  773. j:=LenName;{we can stop}
  774. Found:=true;
  775. end;
  776. end;
  777. #128..#255:
  778. begin
  779. Found:=(j<=LenName) and (pattern[i]=name[j]);
  780. if Found and UTF8 then
  781. begin
  782. { ensure that a part of an UTF-8 codepoint isn't matched with
  783. '*' or '?' }
  784. Found:=CompareUtf8CodePoint(i,j,true);
  785. { at this point, either Found is false (and we'll stop), or
  786. both pattern[i] and name[j] are the end of the current code
  787. point and equal }
  788. end
  789. end
  790. else {not a wildcard character in pattern}
  791. Found:=(j<=LenName) and (pattern[i]=name[j]);
  792. end;
  793. inc(i);
  794. inc(j);
  795. end;
  796. DoFnMatch:=Found and (j>LenName);
  797. end;
  798. Begin {start FNMatch}
  799. LenPat:=Length(Pattern);
  800. LenName:=Length(Name);
  801. FNMatch:=DoFNMatch(1,1);
  802. End;
  803. Type
  804. TUnixFindData = Record
  805. NamePos : LongInt; {to track which search this is}
  806. DirPtr : Pointer; {directory pointer for reading directory}
  807. SearchSpec : RawbyteString;
  808. SearchType : Byte; {0=normal, 1=open will close, 2=only 1 file}
  809. SearchAttr : Longint; {attribute we are searching for}
  810. End;
  811. PUnixFindData = ^TUnixFindData;
  812. Procedure InternalFindClose(var Handle: Pointer);
  813. var
  814. D: PUnixFindData absolute Handle;
  815. begin
  816. If D=Nil then
  817. Exit;
  818. if D^.SearchType=0 then
  819. begin
  820. if D^.dirptr<>nil then
  821. fpclosedir(pdir(D^.dirptr)^);
  822. end;
  823. Dispose(D);
  824. D:=nil;
  825. end;
  826. Function FindGetFileInfo(const s: RawByteString; var f: TAbstractSearchRec; var Name: RawByteString):boolean;
  827. Var
  828. {$ifdef USE_STATX}
  829. stx : linux.tstatx;
  830. {$endif USE_STATX}
  831. st : baseunix.stat;
  832. WinAttr : longint;
  833. begin
  834. {$ifdef USE_STATX}
  835. if Assigned(f.FindHandle) and ( (PUnixFindData(F.FindHandle)^.searchattr and faSymlink) > 0) then
  836. FindGetFileInfo:=statx(AT_FDCWD,pointer(s),AT_SYMLINK_NOFOLLOW,STATX_ALL,stx)=0
  837. else
  838. FindGetFileInfo:=statx(AT_FDCWD,pointer(s),0,STATX_ALL,stx)=0;
  839. if FindGetFileInfo then
  840. begin
  841. WinAttr:=LinuxToWinAttr(s,stx);
  842. FindGetFileInfo:=(WinAttr and Not(PUnixFindData(f.FindHandle)^.searchattr))=0;
  843. if FindGetFileInfo then
  844. begin
  845. Name:=ExtractFileName(s);
  846. f.Attr:=WinAttr;
  847. f.Size:=stx.stx_Size;
  848. f.Mode:=stx.stx_mode;
  849. f.Time:=stx.stx_mtime.tv_sec;
  850. FindGetFileInfo:=true;
  851. end;
  852. end
  853. { no statx? try stat }
  854. else if fpgeterrno=ESysENOSYS then
  855. {$endif USE_STATX}
  856. begin
  857. if Assigned(f.FindHandle) and ( (PUnixFindData(F.FindHandle)^.searchattr and faSymlink) > 0) then
  858. FindGetFileInfo:=(fplstat(pointer(s),st)=0)
  859. else
  860. FindGetFileInfo:=(fpstat(pointer(s),st)=0);
  861. if not FindGetFileInfo then
  862. exit;
  863. WinAttr:=LinuxToWinAttr(s,st);
  864. FindGetFileInfo:=(WinAttr and Not(PUnixFindData(f.FindHandle)^.searchattr))=0;
  865. if FindGetFileInfo then
  866. begin
  867. Name:=ExtractFileName(s);
  868. f.Attr:=WinAttr;
  869. f.Size:=st.st_Size;
  870. f.Mode:=st.st_mode;
  871. f.Time:=st.st_mtime;
  872. FindGetFileInfo:=true;
  873. end;
  874. end;
  875. end;
  876. // Returns the FOUND filename. Error code <> 0 if no file found
  877. Function InternalFindNext (var Rslt : TAbstractSearchRec; var Name : RawByteString) : Longint;
  878. Var
  879. DirName : RawByteString;
  880. FName,
  881. SName : RawBytestring;
  882. Found,
  883. Finished : boolean;
  884. p : pdirent;
  885. UnixFindData : PUnixFindData;
  886. Begin
  887. Result:=-1;
  888. UnixFindData:=PUnixFindData(Rslt.FindHandle);
  889. { SearchSpec='' means that there were no wild cards, so only one file to
  890. find.
  891. }
  892. If (UnixFindData=Nil) or (UnixFindData^.SearchSpec='') then
  893. exit;
  894. if (UnixFindData^.SearchType=0) and
  895. (UnixFindData^.Dirptr=nil) then
  896. begin
  897. If UnixFindData^.NamePos = 0 Then
  898. DirName:='./'
  899. Else
  900. DirName:=Copy(UnixFindData^.SearchSpec,1,UnixFindData^.NamePos);
  901. UnixFindData^.DirPtr := fpopendir(Pchar(DirName));
  902. end;
  903. SName:=Copy(UnixFindData^.SearchSpec,UnixFindData^.NamePos+1,Length(UnixFindData^.SearchSpec));
  904. Found:=False;
  905. Finished:=(UnixFindData^.dirptr=nil);
  906. While Not Finished Do
  907. Begin
  908. p:=fpreaddir(pdir(UnixFindData^.dirptr)^);
  909. if p=nil then
  910. FName:=''
  911. else
  912. FName:=p^.d_name;
  913. If FName='' Then
  914. Finished:=True
  915. Else
  916. Begin
  917. SetCodePage(FName,DefaultFileSystemCodePage,false);
  918. If FNMatch(SName,FName) Then
  919. Begin
  920. Found:=FindGetFileInfo(Copy(UnixFindData^.SearchSpec,1,UnixFindData^.NamePos)+FName,Rslt,Name);
  921. if Found then
  922. begin
  923. Result:=0;
  924. exit;
  925. end;
  926. End;
  927. End;
  928. End;
  929. End;
  930. Function InternalFindFirst (Const Path : RawByteString; Attr : Longint; out Rslt : TAbstractSearchRec; var Name: RawByteString) : Longint;
  931. {
  932. opens dir and calls FindNext if needed.
  933. }
  934. var
  935. UnixFindData : PUnixFindData;
  936. Begin
  937. Result:=-1;
  938. { this is safe even though Rslt actually contains a refcounted field, because
  939. it is declared as "out" and hence has already been initialised }
  940. fillchar(Rslt,sizeof(Rslt),0);
  941. if Path='' then
  942. exit;
  943. { Allocate UnixFindData (we always need it, for the search attributes) }
  944. New(UnixFindData);
  945. FillChar(UnixFindData^,sizeof(UnixFindData^),0);
  946. Rslt.FindHandle:=UnixFindData;
  947. {We always also search for readonly and archive, regardless of Attr:}
  948. UnixFindData^.SearchAttr := Attr or faarchive or fareadonly;
  949. {Wildcards?}
  950. if (Pos('?',Path)=0) and (Pos('*',Path)=0) then
  951. begin
  952. if FindGetFileInfo(ToSingleByteFileSystemEncodedFileName(Path),Rslt,Name) then
  953. Result:=0;
  954. end
  955. else
  956. begin
  957. {Create Info}
  958. UnixFindData^.SearchSpec := ToSingleByteFileSystemEncodedFileName(Path);
  959. UnixFindData^.NamePos := Length(UnixFindData^.SearchSpec);
  960. while (UnixFindData^.NamePos>0) and (UnixFindData^.SearchSpec[UnixFindData^.NamePos]<>'/') do
  961. dec(UnixFindData^.NamePos);
  962. Result:=InternalFindNext(Rslt,Name);
  963. end;
  964. If (Result<>0) then
  965. InternalFindClose(Rslt.FindHandle);
  966. End;
  967. Function FileGetDate (Handle : Longint) : Int64;
  968. Var
  969. Info : Stat;
  970. {$ifdef USE_STATX}
  971. Infox : TStatx;
  972. {$endif USE_STATX}
  973. Char0 : char;
  974. begin
  975. Result:=-1;
  976. {$ifdef USE_STATX}
  977. Char0:=#0;
  978. if statx(Handle,@Char0,AT_EMPTY_PATH,STATX_MTIME,Infox)=0 then
  979. Result:=Infox.stx_Mtime.tv_sec
  980. else if fpgeterrno=ESysENOSYS then
  981. {$endif USE_STATX}
  982. begin
  983. If fpFStat(Handle,Info)=0 then
  984. Result:=Info.st_Mtime;
  985. end;
  986. end;
  987. Function FileSetDate (Handle : Longint;Age : Int64) : Longint;
  988. {$ifdef USE_FUTIMES}
  989. var
  990. times : tkernel_timespecs;
  991. {$endif USE_FUTIMES}
  992. begin
  993. Result:=0;
  994. {$ifdef USE_FUTIMES}
  995. times[0].tv_sec:=Age;
  996. times[0].tv_nsec:=0;
  997. times[1].tv_sec:=Age;
  998. times[1].tv_nsec:=0;
  999. if futimens(Handle,times) = -1 then
  1000. Result:=fpgeterrno;
  1001. {$else USE_FUTIMES}
  1002. FileSetDate:=-1;
  1003. {$endif USE_FUTIMES}
  1004. end;
  1005. Function FileGetAttr (Const FileName : RawByteString) : Longint;
  1006. Var
  1007. SystemFileName: RawByteString;
  1008. Info : Stat;
  1009. res : Integer;
  1010. begin
  1011. SystemFileName:=ToSingleByteFileSystemEncodedFileName(FileName);
  1012. res:=FpLStat(pointer(SystemFileName),Info);
  1013. if res<0 then
  1014. res:=FpStat(pointer(SystemFileName),Info);
  1015. if res<0 then
  1016. Result:=-1
  1017. Else
  1018. Result:=LinuxToWinAttr(SystemFileName,Info);
  1019. end;
  1020. Function FileSetAttr (Const Filename : RawByteString; Attr: longint) : Longint;
  1021. begin
  1022. Result:=-1;
  1023. end;
  1024. Function DeleteFile (Const FileName : RawByteString) : Boolean;
  1025. var
  1026. SystemFileName: RawByteString;
  1027. begin
  1028. SystemFileName:=ToSingleByteFileSystemEncodedFileName(FileName);
  1029. Result:=fpUnLink (pchar(SystemFileName))>=0;
  1030. end;
  1031. Function RenameFile (Const OldName, NewName : RawByteString) : Boolean;
  1032. var
  1033. SystemOldName, SystemNewName: RawByteString;
  1034. begin
  1035. SystemOldName:=ToSingleByteFileSystemEncodedFileName(OldName);
  1036. SystemNewName:=ToSingleByteFileSystemEncodedFileName(NewName);
  1037. RenameFile:=BaseUnix.FpRename(pointer(SystemOldName),pointer(SystemNewName))>=0;
  1038. end;
  1039. Function FileIsReadOnly(const FileName: RawByteString): Boolean;
  1040. var
  1041. SystemFileName: RawByteString;
  1042. begin
  1043. SystemFileName:=ToSingleByteFileSystemEncodedFileName(FileName);
  1044. Result:=fpAccess(PChar(SystemFileName),W_OK)<>0;
  1045. end;
  1046. Function FileSetDate (Const FileName : RawByteString; Age : Int64) : Longint;
  1047. var
  1048. SystemFileName: RawByteString;
  1049. {$ifdef USE_UTIMENSAT}
  1050. times : tkernel_timespecs;
  1051. {$endif USE_UTIMENSAT}
  1052. t: TUTimBuf;
  1053. begin
  1054. SystemFileName:=ToSingleByteFileSystemEncodedFileName(FileName);
  1055. Result:=0;
  1056. {$ifdef USE_UTIMENSAT}
  1057. times[0].tv_sec:=Age;
  1058. times[0].tv_nsec:=0;
  1059. times[1].tv_sec:=Age;
  1060. times[1].tv_nsec:=0;
  1061. if utimensat(AT_FDCWD,PChar(SystemFileName),times,0) = -1 then
  1062. Result:=fpgeterrno;
  1063. if fpgeterrno=ESysENOSYS then
  1064. {$endif USE_UTIMENSAT}
  1065. begin
  1066. Result:=0;
  1067. t.actime:= Age;
  1068. t.modtime:=Age;
  1069. if fputime(PChar(SystemFileName), @t) = -1 then
  1070. Result:=fpgeterrno;
  1071. end
  1072. end;
  1073. {$IF defined(DARWIN)}
  1074. Function IsFileNameCaseSensitive(Const aFileName : RawByteString) : Boolean;
  1075. var
  1076. res : clong;
  1077. begin
  1078. res:=FpPathconf(PChar(aFileName),11 {_PC_CASE_SENSITIVE });
  1079. { fall back to default if path is not found }
  1080. if res<0 then
  1081. Result:=FileNameCaseSensitive
  1082. else
  1083. Result:=res<>0;
  1084. end;
  1085. Function IsFileNameCaseSensitive(Const aFileName : UnicodeString) : Boolean;
  1086. begin
  1087. Result:=IsFileNameCaseSensitive(RawByteString(aFileName));
  1088. end;
  1089. Function IsFileNameCasePreserving(Const aFileName : RawByteString) : Boolean;
  1090. var
  1091. res : clong;
  1092. begin
  1093. res:=FpPathconf(PChar(aFileName),12 { _PC_CASE_PRESERVING });
  1094. if res<0 then
  1095. { fall back to default if path is not found }
  1096. Result:=FileNameCasePreserving
  1097. else
  1098. Result:=res<>0;
  1099. end;
  1100. Function IsFileNameCasePreserving(Const aFileName : UnicodeString) : Boolean;
  1101. begin
  1102. Result:=IsFileNameCasePreserving(RawByteString(aFileName));
  1103. end;
  1104. {$ENDIF defined(DARWIN)}
  1105. {****************************************************************************
  1106. Disk Functions
  1107. ****************************************************************************}
  1108. {
  1109. The Diskfree and Disksize functions need a file on the specified drive, since this
  1110. is required for the fpstatfs system call.
  1111. These filenames are set in drivestr[0..26], and have been preset to :
  1112. 0 - '.' (default drive - hence current dir is ok.)
  1113. 1 - '/fd0/.' (floppy drive 1 - should be adapted to local system )
  1114. 2 - '/fd1/.' (floppy drive 2 - should be adapted to local system )
  1115. 3 - '/' (C: equivalent of dos is the root partition)
  1116. 4..26 (can be set by you're own applications)
  1117. ! Use AddDisk() to Add new drives !
  1118. They both return -1 when a failure occurs.
  1119. }
  1120. Const
  1121. FixDriveStr : array[0..3] of pchar=(
  1122. '.',
  1123. '/fd0/.',
  1124. '/fd1/.',
  1125. '/.'
  1126. );
  1127. var
  1128. Drives : byte = 4;
  1129. DriveStr : array[4..26] of pchar;
  1130. Function GetDriveStr(Drive : Byte) : Pchar;
  1131. begin
  1132. case Drive of
  1133. Low(FixDriveStr)..High(FixDriveStr):
  1134. Result := FixDriveStr[Drive];
  1135. Low(DriveStr)..High(DriveStr):
  1136. Result := DriveStr[Drive];
  1137. else
  1138. Result := nil;
  1139. end;
  1140. end;
  1141. Function DiskFree(Drive: Byte): int64;
  1142. var
  1143. p : PChar;
  1144. fs : TStatfs;
  1145. Begin
  1146. p:=GetDriveStr(Drive);
  1147. if (p<>nil) and (fpStatFS(p, @fs)<>-1) then
  1148. DiskFree := int64(fs.bavail)*int64(fs.bsize)
  1149. else
  1150. DiskFree := -1;
  1151. End;
  1152. Function DiskSize(Drive: Byte): int64;
  1153. var
  1154. p : PChar;
  1155. fs : TStatfs;
  1156. Begin
  1157. p:=GetDriveStr(Drive);
  1158. if (p<>nil) and (fpStatFS(p, @fs)<>-1) then
  1159. DiskSize := int64(fs.blocks)*int64(fs.bsize)
  1160. else
  1161. DiskSize := -1;
  1162. End;
  1163. Function AddDisk(const path: string): Byte;
  1164. begin
  1165. if DriveStr[Drives]<>nil then
  1166. FreeMem(DriveStr[Drives]);
  1167. GetMem(DriveStr[Drives],length(Path)+1);
  1168. StrPCopy(DriveStr[Drives],path);
  1169. Result:=Drives;
  1170. inc(Drives);
  1171. if Drives>High(DriveStr) then
  1172. Drives:=Low(DriveStr);
  1173. end;
  1174. Procedure FreeDriveStr;
  1175. var
  1176. i: longint;
  1177. begin
  1178. for i:=low(drivestr) to high(drivestr) do
  1179. if assigned(drivestr[i]) then
  1180. begin
  1181. freemem(drivestr[i]);
  1182. drivestr[i]:=nil;
  1183. end;
  1184. end;
  1185. {****************************************************************************
  1186. Misc Functions
  1187. ****************************************************************************}
  1188. {****************************************************************************
  1189. Locale Functions
  1190. ****************************************************************************}
  1191. Function GetEpochTime: cint;
  1192. {
  1193. Get the number of seconds since 00:00, January 1 1970, GMT
  1194. the time NOT corrected any way
  1195. }
  1196. begin
  1197. GetEpochTime:=fptime;
  1198. end;
  1199. Procedure DoGetUniversalDateTime(var year, month, day, hour, min, sec, msec, usec : word);
  1200. var
  1201. tz:timeval;
  1202. begin
  1203. fpgettimeofday(@tz,nil);
  1204. EpochToUniversal(tz.tv_sec,year,month,day,hour,min,sec);
  1205. msec:=tz.tv_usec div 1000;
  1206. usec:=tz.tv_usec mod 1000;
  1207. end;
  1208. // Now, adjusted to local time.
  1209. Procedure DoGetLocalDateTime(var year, month, day, hour, min, sec, msec, usec : word);
  1210. var
  1211. tz:timeval;
  1212. begin
  1213. fpgettimeofday(@tz,nil);
  1214. EpochToLocal(tz.tv_sec,year,month,day,hour,min,sec);
  1215. msec:=tz.tv_usec div 1000;
  1216. usec:=tz.tv_usec mod 1000;
  1217. end;
  1218. procedure GetTime(var hour,min,sec,msec,usec:word);
  1219. Var
  1220. year,day,month:Word;
  1221. begin
  1222. DoGetLocalDateTime(year,month,day,hour,min,sec,msec,usec);
  1223. end;
  1224. procedure GetTime(var hour,min,sec,sec100:word);
  1225. {
  1226. Gets the current time, adjusted to local time
  1227. }
  1228. var
  1229. year,day,month,usec : word;
  1230. begin
  1231. DoGetLocalDateTime(year,month,day,hour,min,sec,sec100,usec);
  1232. sec100:=sec100 div 10;
  1233. end;
  1234. Procedure GetTime(Var Hour,Min,Sec:Word);
  1235. {
  1236. Gets the current time, adjusted to local time
  1237. }
  1238. var
  1239. year,day,month,msec,usec : Word;
  1240. Begin
  1241. DoGetLocalDateTime(year,month,day,hour,min,sec,msec,usec);
  1242. End;
  1243. Procedure GetDate(Var Year,Month,Day:Word);
  1244. {
  1245. Gets the current date, adjusted to local time
  1246. }
  1247. var
  1248. hour,minute,second,msec,usec : word;
  1249. Begin
  1250. DoGetLocalDateTime(year,month,day,hour,minute,second,msec,usec);
  1251. End;
  1252. Procedure GetDateTime(Var Year,Month,Day,hour,minute,second:Word);
  1253. {
  1254. Gets the current date, adjusted to local time
  1255. }
  1256. Var
  1257. usec,msec : word;
  1258. Begin
  1259. DoGetLocalDateTime(year,month,day,hour,minute,second,msec,usec);
  1260. End;
  1261. {$ifndef FPUNONE}
  1262. Procedure GetLocalTime(var SystemTime: TSystemTime);
  1263. var
  1264. usecs : Word;
  1265. begin
  1266. DoGetLocalDateTime(SystemTime.Year, SystemTime.Month, SystemTime.Day,SystemTime.Hour, SystemTime.Minute, SystemTime.Second, SystemTime.MilliSecond, usecs);
  1267. SystemTime.DayOfWeek:=DayOfWeek(EncodeDate(SystemTime.Year,SystemTime.Month,SystemTime.Day))-1;
  1268. end ;
  1269. {$endif}
  1270. Procedure InitAnsi;
  1271. Var
  1272. i : longint;
  1273. begin
  1274. { Fill table entries 0 to 127 }
  1275. for i := 0 to 96 do
  1276. UpperCaseTable[i] := chr(i);
  1277. for i := 97 to 122 do
  1278. UpperCaseTable[i] := chr(i - 32);
  1279. for i := 123 to 191 do
  1280. UpperCaseTable[i] := chr(i);
  1281. Move (CPISO88591UCT,UpperCaseTable[192],SizeOf(CPISO88591UCT));
  1282. for i := 0 to 64 do
  1283. LowerCaseTable[i] := chr(i);
  1284. for i := 65 to 90 do
  1285. LowerCaseTable[i] := chr(i + 32);
  1286. for i := 91 to 191 do
  1287. LowerCaseTable[i] := chr(i);
  1288. Move (CPISO88591LCT,LowerCaseTable[192],SizeOf(CPISO88591UCT));
  1289. end;
  1290. Procedure InitInternational;
  1291. begin
  1292. InitInternationalGeneric;
  1293. InitAnsi;
  1294. end;
  1295. function SysErrorMessage(ErrorCode: Integer): String;
  1296. begin
  1297. Result:=StrError(ErrorCode);
  1298. end;
  1299. {****************************************************************************
  1300. OS utility functions
  1301. ****************************************************************************}
  1302. Function GetEnvironmentVariable(Const EnvVar : String) : String;
  1303. begin
  1304. { no need to adjust the code page of EnvVar to DefaultSystemCodePage, as only
  1305. ASCII identifiers are supported }
  1306. Result:=BaseUnix.FPGetenv(PChar(pointer(EnvVar)));
  1307. end;
  1308. Function GetEnvironmentVariableCount : Integer;
  1309. begin
  1310. Result:=FPCCountEnvVar(EnvP);
  1311. end;
  1312. Function GetEnvironmentString(Index : Integer) : {$ifdef FPC_RTL_UNICODE}UnicodeString{$else}AnsiString{$endif};
  1313. begin
  1314. Result:=FPCGetEnvStrFromP(Envp,Index);
  1315. end;
  1316. function ExecuteProcess(Const Path: RawByteString; Const ComLine: RawByteString;Flags:TExecuteFlags=[]):integer;
  1317. var
  1318. pid : longint;
  1319. e : EOSError;
  1320. CommandLine: RawByteString;
  1321. LPath : RawByteString;
  1322. cmdline2 : ppchar;
  1323. Begin
  1324. { always surround the name of the application by quotes
  1325. so that long filenames will always be accepted. But don't
  1326. do it if there are already double quotes!
  1327. }
  1328. // Only place we still parse
  1329. cmdline2:=nil;
  1330. LPath:=Path;
  1331. UniqueString(LPath);
  1332. SetCodePage(LPath,DefaultFileSystemCodePage,true);
  1333. if Comline<>'' Then
  1334. begin
  1335. CommandLine:=ComLine;
  1336. { Make an unique copy because stringtoppchar modifies the
  1337. string, and force conversion to intended fscp }
  1338. UniqueString(CommandLine);
  1339. SetCodePage(CommandLine,DefaultFileSystemCodePage,true);
  1340. cmdline2:=StringtoPPChar(CommandLine,1);
  1341. cmdline2^:=pchar(pointer(LPath));
  1342. end
  1343. else
  1344. begin
  1345. getmem(cmdline2,2*sizeof(pchar));
  1346. cmdline2^:=pchar(LPath);
  1347. cmdline2[1]:=nil;
  1348. end;
  1349. {$ifdef USE_VFORK}
  1350. pid:=fpvFork;
  1351. {$else USE_VFORK}
  1352. pid:=fpFork;
  1353. {$endif USE_VFORK}
  1354. if pid=0 then
  1355. begin
  1356. {The child does the actual exec, and then exits}
  1357. fpexecv(pchar(pointer(LPath)),Cmdline2);
  1358. { If the execve fails, we return an exitvalue of 127, to let it be known}
  1359. fpExit(127);
  1360. end
  1361. else
  1362. if pid=-1 then {Fork failed}
  1363. begin
  1364. e:=EOSError.CreateFmt(SExecuteProcessFailed,[LPath,-1]);
  1365. e.ErrorCode:=-1;
  1366. raise e;
  1367. end;
  1368. { We're in the parent, let's wait. }
  1369. result:=WaitProcess(pid); // WaitPid and result-convert
  1370. if Comline<>'' Then
  1371. freemem(cmdline2);
  1372. if (result<0) or (result=127) then
  1373. begin
  1374. E:=EOSError.CreateFmt(SExecuteProcessFailed,[LPath,result]);
  1375. E.ErrorCode:=result;
  1376. Raise E;
  1377. end;
  1378. End;
  1379. function ExecuteProcess(Const Path: RawByteString; Const ComLine: Array Of RawByteString;Flags:TExecuteFlags=[]):integer;
  1380. var
  1381. pid : longint;
  1382. e : EOSError;
  1383. Begin
  1384. pid:=fpFork;
  1385. if pid=0 then
  1386. begin
  1387. {The child does the actual exec, and then exits}
  1388. fpexecl(Path,Comline);
  1389. { If the execve fails, we return an exitvalue of 127, to let it be known}
  1390. fpExit(127);
  1391. end
  1392. else
  1393. if pid=-1 then {Fork failed}
  1394. begin
  1395. e:=EOSError.CreateFmt(SExecuteProcessFailed,[Path,-1]);
  1396. e.ErrorCode:=-1;
  1397. raise e;
  1398. end;
  1399. { We're in the parent, let's wait. }
  1400. result:=WaitProcess(pid); // WaitPid and result-convert
  1401. if (result<0) or (result=127) then
  1402. begin
  1403. E:=EOSError.CreateFmt(SExecuteProcessFailed,[Path,result]);
  1404. E.ErrorCode:=result;
  1405. raise E;
  1406. end;
  1407. End;
  1408. procedure Sleep(milliseconds: Cardinal);
  1409. Var
  1410. timeout,timeoutresult : TTimespec;
  1411. res: cint;
  1412. begin
  1413. timeout.tv_sec:=milliseconds div 1000;
  1414. timeout.tv_nsec:=1000*1000*(milliseconds mod 1000);
  1415. repeat
  1416. res:=fpnanosleep(@timeout,@timeoutresult);
  1417. timeout:=timeoutresult;
  1418. until (res<>-1) or (fpgeterrno<>ESysEINTR);
  1419. end;
  1420. Function GetLastOSError : Integer;
  1421. begin
  1422. Result:=fpgetErrNo;
  1423. end;
  1424. { ---------------------------------------------------------------------
  1425. Application config files
  1426. ---------------------------------------------------------------------}
  1427. {$ifdef android}
  1428. var
  1429. _HomeDir: string;
  1430. _HasPackageDataDir: boolean;
  1431. Function GetHomeDir : String;
  1432. var
  1433. h: longint;
  1434. i: longint;
  1435. begin
  1436. Result:=_HomeDir;
  1437. if Result <> '' then
  1438. exit;
  1439. if IsLibrary then
  1440. begin
  1441. // For shared library get the package name of a host Java application
  1442. h:=FileOpen('/proc/self/cmdline', fmOpenRead or fmShareDenyNone);
  1443. if h >= 0 then
  1444. begin
  1445. SetLength(Result, MAX_PATH);
  1446. SetLength(Result, FileRead(h, Result[1], Length(Result)));
  1447. SetLength(Result, strlen(PChar(Result)));
  1448. FileClose(h);
  1449. Result:='/data/data/' + Result;
  1450. _HasPackageDataDir:=DirectoryExists(Result);
  1451. if _HasPackageDataDir then
  1452. begin
  1453. Result:=Result + '/files/';
  1454. ForceDirectories(Result);
  1455. end
  1456. else
  1457. Result:=''; // No package
  1458. end;
  1459. end;
  1460. if Result = '' then
  1461. Result:='/data/local/tmp/';
  1462. _HomeDir:=Result;
  1463. end;
  1464. Function XdgConfigHome : String;
  1465. begin
  1466. Result:=GetHomeDir;
  1467. end;
  1468. {$else}
  1469. Function GetHomeDir : String;
  1470. begin
  1471. Result:=GetEnvironmentVariable('HOME');
  1472. If (Result<>'') then
  1473. Result:=IncludeTrailingPathDelimiter(Result);
  1474. end;
  1475. { Follows base-dir spec,
  1476. see [http://freedesktop.org/Standards/basedir-spec].
  1477. Always ends with PathDelim. }
  1478. Function XdgConfigHome : String;
  1479. begin
  1480. Result:=GetEnvironmentVariable('XDG_CONFIG_HOME');
  1481. if (Result='') then
  1482. Result:=GetHomeDir + '.config/'
  1483. else
  1484. Result:=IncludeTrailingPathDelimiter(Result);
  1485. end;
  1486. {$endif android}
  1487. Function GetAppConfigDir(Global : Boolean) : String;
  1488. begin
  1489. If Global then
  1490. Result:=IncludeTrailingPathDelimiter(SysConfigDir)
  1491. else
  1492. Result:=IncludeTrailingPathDelimiter(XdgConfigHome);
  1493. {$ifdef android}
  1494. if _HasPackageDataDir then
  1495. exit;
  1496. {$endif android}
  1497. if VendorName<>'' then
  1498. Result:=IncludeTrailingPathDelimiter(Result+VendorName);
  1499. Result:=IncludeTrailingPathDelimiter(Result+ApplicationName);
  1500. end;
  1501. Function GetAppConfigFile(Global : Boolean; SubDir : Boolean) : String;
  1502. begin
  1503. If Global then
  1504. Result:=IncludeTrailingPathDelimiter(SysConfigDir)
  1505. else
  1506. Result:=IncludeTrailingPathDelimiter(XdgConfigHome);
  1507. {$ifdef android}
  1508. if _HasPackageDataDir then
  1509. begin
  1510. Result:=Result+'config'+ConfigExtension;
  1511. exit;
  1512. end;
  1513. {$endif android}
  1514. if SubDir then
  1515. begin
  1516. if VendorName<>'' then
  1517. Result:=IncludeTrailingPathDelimiter(Result+VendorName);
  1518. Result:=IncludeTrailingPathDelimiter(Result+ApplicationName);
  1519. end;
  1520. Result:=Result+ApplicationName+ConfigExtension;
  1521. end;
  1522. {****************************************************************************
  1523. GetTempDir
  1524. ****************************************************************************}
  1525. Function GetTempDir(Global : Boolean) : String;
  1526. begin
  1527. If Assigned(OnGetTempDir) then
  1528. Result:=OnGetTempDir(Global)
  1529. else
  1530. begin
  1531. {$ifdef android}
  1532. Result:=GetHomeDir + 'tmp';
  1533. ForceDirectories(Result);
  1534. {$else}
  1535. Result:=GetEnvironmentVariable('TEMP');
  1536. If (Result='') Then
  1537. Result:=GetEnvironmentVariable('TMP');
  1538. If (Result='') Then
  1539. Result:=GetEnvironmentVariable('TMPDIR');
  1540. if (Result='') then
  1541. Result:='/tmp/'; // fallback.
  1542. {$endif android}
  1543. end;
  1544. if (Result<>'') then
  1545. Result:=IncludeTrailingPathDelimiter(Result);
  1546. end;
  1547. {****************************************************************************
  1548. GetUserDir
  1549. ****************************************************************************}
  1550. Var
  1551. TheUserDir : String;
  1552. Function GetUserDir : String;
  1553. begin
  1554. If (TheUserDir='') then
  1555. begin
  1556. {$ifdef android}
  1557. TheUserDir:=GetHomeDir;
  1558. {$else}
  1559. TheUserDir:=GetEnvironmentVariable('HOME');
  1560. {$endif android}
  1561. if (TheUserDir<>'') then
  1562. TheUserDir:=IncludeTrailingPathDelimiter(TheUserDir)
  1563. else
  1564. TheUserDir:=GetTempDir(False);
  1565. end;
  1566. Result:=TheUserDir;
  1567. end;
  1568. Procedure SysBeep;
  1569. begin
  1570. Write(#7);
  1571. Flush(Output);
  1572. end;
  1573. function GetUniversalTime(var SystemTime: TSystemTime): Boolean;
  1574. var
  1575. usecs : Word;
  1576. begin
  1577. DoGetUniversalDateTime(SystemTime.Year, SystemTime.Month, SystemTime.Day,SystemTime.Hour, SystemTime.Minute, SystemTime.Second, SystemTime.MilliSecond, usecs);
  1578. Result:=True;
  1579. end;
  1580. function GetLocalTimeOffset: Integer;
  1581. begin
  1582. Result := -Tzseconds div 60;
  1583. end;
  1584. function GetLocalTimeOffset(const DateTime: TDateTime; const InputIsUTC: Boolean; out Offset: Integer): Boolean;
  1585. var
  1586. Year, Month, Day, Hour, Minute, Second, MilliSecond: word;
  1587. UnixTime: Int64;
  1588. lTZInfo: TTZInfo;
  1589. begin
  1590. DecodeDate(DateTime, Year, Month, Day);
  1591. DecodeTime(DateTime, Hour, Minute, Second, MilliSecond);
  1592. UnixTime:=UniversalToEpoch(Year, Month, Day, Hour, Minute, Second);
  1593. {$if declared(GetLocalTimezone)}
  1594. GetLocalTimeOffset:=GetLocalTimezone(UnixTime,InputIsUTC,lTZInfo);
  1595. if GetLocalTimeOffset then
  1596. Offset:=-lTZInfo.seconds div 60;
  1597. {$else}
  1598. GetLocalTimeOffset:=False;
  1599. {$endif}
  1600. end;
  1601. {$ifdef android}
  1602. procedure InitAndroid;
  1603. var
  1604. dlinfo: dl_info;
  1605. s: string;
  1606. begin
  1607. FillChar(dlinfo, sizeof(dlinfo), 0);
  1608. dladdr(@InitAndroid, @dlinfo);
  1609. s:=dlinfo.dli_fname;
  1610. if s <> '' then
  1611. SetDefaultSysLogTag(ExtractFileName(s));
  1612. end;
  1613. {$endif android}
  1614. {****************************************************************************
  1615. Initialization code
  1616. ****************************************************************************}
  1617. Initialization
  1618. InitExceptions; { Initialize exceptions. OS independent }
  1619. InitInternational; { Initialize internationalization settings }
  1620. SysConfigDir:='/etc'; { Initialize system config dir }
  1621. OnBeep:=@SysBeep;
  1622. {$ifdef android}
  1623. InitAndroid;
  1624. {$endif android}
  1625. Finalization
  1626. FreeDriveStr;
  1627. FreeTerminateProcs;
  1628. DoneExceptions;
  1629. end.