dos.pp 46 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724
  1. {
  2. $Id$
  3. This file is part of the Free Pascal run time library.
  4. Copyright (c) 1998 by Nils Sjoholm and Carl Eric Codere
  5. members of the Free Pascal development team
  6. Date conversion routine taken from SWAG
  7. See the file COPYING.FPC, included in this distribution,
  8. for details about the copyright.
  9. This program is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  12. **********************************************************************}
  13. Unit Dos;
  14. {--------------------------------------------------------------------}
  15. { LEFT TO DO: }
  16. {--------------------------------------------------------------------}
  17. { o DiskFree / Disksize don't work as expected }
  18. { o Implement SetDate and SetTime }
  19. { o Implement EnvCount,EnvStr }
  20. { o FindFirst should only work with correct attributes }
  21. {--------------------------------------------------------------------}
  22. Interface
  23. {$I os.inc}
  24. Const
  25. {Bitmasks for CPU Flags}
  26. fcarry = $0001;
  27. fparity = $0004;
  28. fauxiliary = $0010;
  29. fzero = $0040;
  30. fsign = $0080;
  31. foverflow = $0800;
  32. {Bitmasks for file attribute}
  33. readonly = $01;
  34. hidden = $02;
  35. sysfile = $04;
  36. volumeid = $08;
  37. directory = $10;
  38. archive = $20;
  39. anyfile = $3F;
  40. {File Status}
  41. fmclosed = $D7B0;
  42. fminput = $D7B1;
  43. fmoutput = $D7B2;
  44. fminout = $D7B3;
  45. Type
  46. ComStr = String[255]; { size increased to be more compatible with Unix}
  47. PathStr = String[255]; { size increased to be more compatible with Unix}
  48. DirStr = String[255]; { size increased to be more compatible with Unix}
  49. NameStr = String[255]; { size increased to be more compatible with Unix}
  50. ExtStr = String[255]; { size increased to be more compatible with Unix}
  51. {
  52. filerec.inc contains the definition of the filerec.
  53. textrec.inc contains the definition of the textrec.
  54. It is in a separate file to make it available in other units without
  55. having to use the DOS unit for it.
  56. }
  57. {$i filerec.inc}
  58. {$i textrec.inc}
  59. Type
  60. SearchRec = Packed Record
  61. { watch out this is correctly aligned for all processors }
  62. { don't modify. }
  63. { Replacement for Fill }
  64. {0} AnchorPtr : Pointer; { Pointer to the Anchorpath structure }
  65. {4} Fill: Array[1..15] of Byte; {future use}
  66. {End of replacement for fill}
  67. Attr : BYTE; {attribute of found file}
  68. Time : LongInt; {last modify date of found file}
  69. Size : LongInt; {file size of found file}
  70. Name : String[255]; {name of found file}
  71. End;
  72. DateTime = packed record
  73. Year: Word;
  74. Month: Word;
  75. Day: Word;
  76. Hour: Word;
  77. Min: Word;
  78. Sec: word;
  79. End;
  80. Var
  81. DosError : integer;
  82. {Interrupt}
  83. {Procedure Intr(intno: byte; var regs: registers);
  84. Procedure MSDos(var regs: registers);}
  85. {Info/Date/Time}
  86. Function DosVersion: Word;
  87. Procedure GetDate(var year, month, mday, wday: word);
  88. Procedure GetTime(var hour, minute, second, sec100: word);
  89. procedure SetDate(year,month,day: word);
  90. Procedure SetTime(hour,minute,second,sec100: word);
  91. Procedure UnpackTime(p: longint; var t: datetime);
  92. Procedure PackTime(var t: datetime; var p: longint);
  93. {Exec}
  94. Procedure Exec(const path: pathstr; const comline: comstr);
  95. Function DosExitCode: word;
  96. {Disk}
  97. Function DiskFree(drive: byte) : longint;
  98. Function DiskSize(drive: byte) : longint;
  99. Procedure FindFirst(path: pathstr; attr: word; var f: searchRec);
  100. Procedure FindNext(var f: searchRec);
  101. Procedure FindClose(Var f: SearchRec);
  102. {File}
  103. Procedure GetFAttr(var f; var attr: word);
  104. Procedure GetFTime(var f; var time: longint);
  105. Function FSearch(path: pathstr; dirlist: string): pathstr;
  106. Function FExpand(path: pathstr): pathstr;
  107. Procedure FSplit(path: pathstr; var dir: dirstr; var name: namestr; var ext: extstr);
  108. {Environment}
  109. Function EnvCount: longint;
  110. Function EnvStr(index: integer): string;
  111. Function GetEnv(envvar: string): string;
  112. {Misc}
  113. Procedure SetFAttr(var f; attr: word);
  114. Procedure SetFTime(var f; time: longint);
  115. Procedure GetCBreak(var breakvalue: boolean);
  116. Procedure SetCBreak(breakvalue: boolean);
  117. Procedure GetVerify(var verify: boolean);
  118. Procedure SetVerify(verify: boolean);
  119. {Do Nothing Functions}
  120. Procedure SwapVectors;
  121. Procedure GetIntVec(intno: byte; var vector: pointer);
  122. Procedure SetIntVec(intno: byte; vector: pointer);
  123. Procedure Keep(exitcode: word);
  124. implementation
  125. const
  126. DaysPerMonth : Array[1..12] of ShortInt =
  127. (031,028,031,030,031,030,031,031,030,031,030,031);
  128. DaysPerYear : Array[1..12] of Integer =
  129. (031,059,090,120,151,181,212,243,273,304,334,365);
  130. DaysPerLeapYear : Array[1..12] of Integer =
  131. (031,060,091,121,152,182,213,244,274,305,335,366);
  132. SecsPerYear : LongInt = 31536000;
  133. SecsPerLeapYear : LongInt = 31622400;
  134. SecsPerDay : LongInt = 86400;
  135. SecsPerHour : Integer = 3600;
  136. SecsPerMinute : ShortInt = 60;
  137. TICKSPERSECOND = 50;
  138. Type
  139. pClockData = ^tClockData;
  140. tClockData = packed Record
  141. sec : Word;
  142. min : Word;
  143. hour : Word;
  144. mday : Word;
  145. month : Word;
  146. year : Word;
  147. wday : Word;
  148. END;
  149. BPTR = Longint;
  150. BSTR = Longint;
  151. pMinNode = ^tMinNode;
  152. tMinNode = Packed Record
  153. mln_Succ,
  154. mln_Pred : pMinNode;
  155. End;
  156. pMinList = ^tMinList;
  157. tMinList = Packed record
  158. mlh_Head : pMinNode;
  159. mlh_Tail : pMinNode;
  160. mlh_TailPred : pMinNode;
  161. end;
  162. { * List Node Structure. Each member in a list starts with a Node * }
  163. pNode = ^tNode;
  164. tNode = Packed Record
  165. ln_Succ, { * Pointer to next (successor) * }
  166. ln_Pred : pNode; { * Pointer to previous (predecessor) * }
  167. ln_Type : Byte;
  168. ln_Pri : Shortint; { * Priority, for sorting * }
  169. ln_Name : PCHAR; { * ID string, null terminated * }
  170. End; { * Note: Integer aligned * }
  171. pList = ^tList;
  172. tList = Packed record
  173. lh_Head : pNode;
  174. lh_Tail : pNode;
  175. lh_TailPred : pNode;
  176. lh_Type : Byte;
  177. l_pad : Byte;
  178. end;
  179. pMsgPort = ^tMsgPort;
  180. tMsgPort = Packed record
  181. mp_Node : tNode;
  182. mp_Flags : Byte;
  183. mp_SigBit : Byte; { signal bit number }
  184. mp_SigTask : Pointer; { task to be signalled (TaskPtr) }
  185. mp_MsgList : tList; { message linked list }
  186. end;
  187. pTask = ^tTask;
  188. tTask = Packed record
  189. tc_Node : tNode;
  190. tc_Flags : Byte;
  191. tc_State : Byte;
  192. tc_IDNestCnt : Shortint; { intr disabled nesting }
  193. tc_TDNestCnt : Shortint; { task disabled nesting }
  194. tc_SigAlloc : Cardinal { sigs allocated }
  195. tc_SigWait : Cardinal; { sigs we are waiting for }
  196. tc_SigRecvd : Cardinal; { sigs we have received }
  197. tc_SigExcept : Cardinal; { sigs we will take excepts for }
  198. tc_TrapAlloc : Word; { traps allocated }
  199. tc_TrapAble : Word; { traps enabled }
  200. tc_ExceptData : Pointer; { points to except data }
  201. tc_ExceptCode : Pointer; { points to except code }
  202. tc_TrapData : Pointer; { points to trap data }
  203. tc_TrapCode : Pointer; { points to trap code }
  204. tc_SPReg : Pointer; { stack pointer }
  205. tc_SPLower : Pointer; { stack lower bound }
  206. tc_SPUpper : Pointer; { stack upper bound + 2 }
  207. tc_Switch : Pointer; { task losing CPU }
  208. tc_Launch : Pointer; { task getting CPU }
  209. tc_MemEntry : tList; { allocated memory }
  210. tc_UserData : Pointer; { per task data }
  211. end;
  212. TDateStamp = packed record
  213. ds_Days : Longint; { Number of days since Jan. 1, 1978 }
  214. ds_Minute : Longint; { Number of minutes past midnight }
  215. ds_Tick : Longint; { Number of ticks past minute }
  216. end;
  217. PDateStamp = ^TDateStamp;
  218. { Returned by Examine() and ExInfo(), must be on a 4 byte boundary }
  219. PFileInfoBlock = ^TfileInfoBlock;
  220. TFileInfoBlock = packed record
  221. fib_DiskKey : Longint;
  222. fib_DirEntryType : Longint;
  223. { Type of Directory. If < 0, then a plain file.
  224. If > 0 a directory }
  225. fib_FileName : Array [0..107] of Char;
  226. { Null terminated. Max 30 chars used for now }
  227. fib_Protection : Longint;
  228. { bit mask of protection, rwxd are 3-0. }
  229. fib_EntryType : Longint;
  230. fib_Size : Longint; { Number of bytes in file }
  231. fib_NumBlocks : Longint; { Number of blocks in file }
  232. fib_Date : TDateStamp; { Date file last changed }
  233. fib_Comment : Array [0..79] of Char;
  234. { Null terminated comment associated with file }
  235. fib_Reserved : Array [0..35] of Char;
  236. end;
  237. { returned by Info(), must be on a 4 byte boundary }
  238. pInfoData = ^tInfoData;
  239. tInfoData = packed record
  240. id_NumSoftErrors : Longint; { number of soft errors on disk }
  241. id_UnitNumber : Longint; { Which unit disk is (was) mounted on }
  242. id_DiskState : Longint; { See defines below }
  243. id_NumBlocks : Longint; { Number of blocks on disk }
  244. id_NumBlocksUsed : Longint; { Number of block in use }
  245. id_BytesPerBlock : Longint;
  246. id_DiskType : Longint; { Disk Type code }
  247. id_VolumeNode : BPTR; { BCPL pointer to volume node }
  248. id_InUse : Longint; { Flag, zero if not in use }
  249. end;
  250. { ------ Library Base Structure ---------------------------------- }
  251. { Also used for Devices and some Resources }
  252. pLibrary = ^tLibrary;
  253. tLibrary = packed record
  254. lib_Node : tNode;
  255. lib_Flags,
  256. lib_pad : Byte;
  257. lib_NegSize, { number of bytes before library }
  258. lib_PosSize, { number of bytes after library }
  259. lib_Version, { major }
  260. lib_Revision : Word; { minor }
  261. lib_IdString : PCHAR; { ASCII identification }
  262. lib_Sum : LONGINT; { the checksum itself }
  263. lib_OpenCnt : Word; { number of current opens }
  264. end; { * Warning: size is not a longword multiple ! * }
  265. PChain = ^TChain;
  266. TChain = packed record
  267. an_Child : PChain;
  268. an_Parent: PChain;
  269. an_Lock : BPTR;
  270. an_info : TFileInfoBlock;
  271. an_Flags : shortint;
  272. an_string: Array[0..0] of char;
  273. end;
  274. PAnchorPath = ^TAnchorPath;
  275. TAnchorPath = packed record
  276. ap_Base : PChain; {* pointer to first anchor *}
  277. ap_First : PChain; {* pointer to last anchor *}
  278. ap_BreakBits : LONGINT; {* Bits we want to break on *}
  279. ap_FondBreak : LONGINT; {* Bits we broke on. Also returns ERROR_BREAK *}
  280. ap_Flags : shortint; {* New use for extra word. *}
  281. ap_reserved : BYTE;
  282. ap_StrLen : WORD;
  283. ap_Info : TFileInfoBlock;
  284. ap_Buf : Array[0..0] of Char; {* Buffer for path name, allocated by user *}
  285. END;
  286. pCommandLineInterface = ^TCommandLineInterface;
  287. TCommandLineInterface = packed record
  288. cli_result2 : longint; {* Value of IoErr from last command *}
  289. cli_SetName : BSTR; {* Name of current directory *}
  290. cli_CommandDir : BPTR; {* Head of the path locklist *}
  291. cli_ReturnCode : longint; {* Return code from last command *}
  292. cli_CommandName : BSTR; {* Name of current command *}
  293. cli_FailLevel : longint; {* Fail level (set by FAILAT) *}
  294. cli_Prompt : BSTR; {* Current prompt (set by PROMPT) *}
  295. cli_StandardInput: BPTR; {* Default (terminal) CLI input *}
  296. cli_CurrentInput : BPTR; {* Current CLI input *}
  297. cli_CommandFile : BSTR; {* Name of EXECUTE command file *}
  298. cli_Interactive : longint; {* Boolean; True if prompts required *}
  299. cli_Background : longint {* Boolean; True if CLI created by RUN*}
  300. cli_CurrentOutput: BPTR; {* Current CLI output *}
  301. cli_DefautlStack : longint; {* Stack size to be obtained in long words *}
  302. cli_StandardOutput : BPTR; {* Default (terminal) CLI output *}
  303. cli_Module : BPTR; {* SegList of currently loaded command*}
  304. END;
  305. pDosList = ^tDosList;
  306. tDosList = packed record
  307. dol_Next : BPTR; { bptr to next device on list }
  308. dol_Type : Longint; { see DLT below }
  309. dol_Task : Pointer; { ptr to handler task }
  310. dol_Lock : BPTR;
  311. dol_Misc : Array[0..23] of Shortint;
  312. dol_Name : BSTR; { bptr to bcpl name }
  313. END;
  314. TProcess = packed record
  315. pr_Task : TTask;
  316. pr_MsgPort : TMsgPort; { This is BPTR address from DOS functions }
  317. {126} pr_Pad : Word; { Remaining variables on 4 byte boundaries }
  318. {128} pr_SegList : Pointer; { Array of seg lists used by this process }
  319. {132} pr_StackSize : Longint; { Size of process stack in bytes }
  320. {136} pr_GlobVec : Pointer; { Global vector for this process (BCPL) }
  321. {140} pr_TaskNum : Longint; { CLI task number of zero if not a CLI }
  322. {144} pr_StackBase : BPTR; { Ptr to high memory end of process stack }
  323. {148} pr_Result2 : Longint; { Value of secondary result from last call }
  324. {152} pr_CurrentDir : BPTR; { Lock associated with current directory }
  325. {156} pr_CIS : BPTR; { Current CLI Input Stream }
  326. {160} pr_COS : BPTR; { Current CLI Output Stream }
  327. {164} pr_ConsoleTask : Pointer; { Console handler process for current window}
  328. {168} pr_FileSystemTask : Pointer; { File handler process for current drive }
  329. {172} pr_CLI : BPTR; { pointer to ConsoleLineInterpreter }
  330. pr_ReturnAddr : Pointer; { pointer to previous stack frame }
  331. pr_PktWait : Pointer; { Function to be called when awaiting msg }
  332. pr_WindowPtr : Pointer; { Window for error printing }
  333. { following definitions are new with 2.0 }
  334. pr_HomeDir : BPTR; { Home directory of executing program }
  335. pr_Flags : Longint; { flags telling dos about process }
  336. pr_ExitCode : Pointer; { code to call on exit of program OR NULL }
  337. pr_ExitData : Longint; { Passed as an argument to pr_ExitCode. }
  338. pr_Arguments : PChar; { Arguments passed to the process at start }
  339. pr_LocalVars : TMinList; { Local environment variables }
  340. pr_ShellPrivate : Longint; { for the use of the current shell }
  341. pr_CES : BPTR; { Error stream - IF NULL, use pr_COS }
  342. end;
  343. PProcess = ^TProcess;
  344. CONST
  345. { DOS Lib Offsets }
  346. _LVOMatchFirst = -822;
  347. _LVOMatchNext = -828;
  348. _LVOMatchEnd = -834;
  349. _LVOCli = -492;
  350. _LVOExecute = -222;
  351. _LVOSystemTagList = -606;
  352. _LVOSetFileDate = -396;
  353. LDF_READ = 1;
  354. LDF_DEVICES = 4;
  355. ERROR_NO_MORE_ENTRIES = 232;
  356. FIBF_SCRIPT = 64; { program is a script }
  357. FIBF_PURE = 32; { program is reentrant }
  358. FIBF_ARCHIVE = 16; { cleared whenever file is changed }
  359. FIBF_READ = 8; { ignoed by old filesystem }
  360. FIBF_WRITE = 4; { ignored by old filesystem }
  361. FIBF_EXECUTE = 2; { ignored by system, used by shell }
  362. FIBF_DELETE = 1; { prevent file from being deleted }
  363. SHARED_LOCK = -2;
  364. {******************************************************************************
  365. --- Internal routines ---
  366. ******************************************************************************}
  367. procedure CurrentTime(var Seconds, Micros : Longint);
  368. Begin
  369. asm
  370. MOVE.L A6,-(A7)
  371. MOVE.L Seconds,a0
  372. MOVE.L Micros,a1
  373. MOVE.L _IntuitionBase,A6
  374. JSR -084(A6)
  375. MOVE.L (A7)+,A6
  376. end;
  377. end;
  378. function Date2Amiga(date : pClockData) : Longint;
  379. Begin
  380. asm
  381. MOVE.L A6,-(A7)
  382. MOVE.L date,a0
  383. MOVE.L _UtilityBase,A6
  384. JSR -126(A6)
  385. MOVE.L (A7)+,A6
  386. MOVE.L d0,@RESULT
  387. end;
  388. end;
  389. procedure Amiga2Date(amigatime : Longint;
  390. resultat : pClockData);
  391. Begin
  392. asm
  393. MOVE.L A6,-(A7)
  394. MOVE.L amigatime,d0
  395. MOVE.L resultat,a0
  396. MOVE.L _UtilityBase,A6
  397. JSR -120(A6)
  398. MOVE.L (A7)+,A6
  399. end;
  400. end;
  401. FUNCTION Examine(lock : BPTR; fileInfoBlock : pFileInfoBlock) : BOOLEAN;
  402. BEGIN
  403. ASM
  404. MOVE.L A6,-(A7)
  405. MOVE.L lock,D1
  406. MOVE.L fileInfoBlock,D2
  407. MOVEA.L _DOSBase,A6
  408. JSR -102(A6)
  409. MOVEA.L (A7)+,A6
  410. TST.L D0
  411. BEQ.B @end
  412. MOVE.B #1,D0
  413. @end: MOVE.B D0,@RESULT
  414. END;
  415. END;
  416. function Lock(const name : string;
  417. accessmode : Longint) : BPTR;
  418. var
  419. buffer: Array[0..255] of char;
  420. Begin
  421. move(name[1],buffer,length(name));
  422. buffer[length(name)]:=#0;
  423. asm
  424. MOVEM.L d2/a6,-(A7)
  425. LEA buffer,a0
  426. MOVE.L a0,d1
  427. MOVE.L accessmode,d2
  428. MOVE.L _DOSBase,A6
  429. JSR -084(A6)
  430. MOVEM.L (A7)+,d2/a6
  431. MOVE.L d0,@RESULT
  432. end;
  433. end;
  434. procedure UnLock(lock : BPTR);
  435. Begin
  436. asm
  437. MOVE.L A6,-(A7)
  438. MOVE.L lock,d1
  439. MOVE.L _DOSBase,A6
  440. JSR -090(A6)
  441. MOVE.L (A7)+,A6
  442. end;
  443. end;
  444. FUNCTION Info(lock : BPTR; parameterBlock : pInfoData) : BOOLEAN;
  445. BEGIN
  446. ASM
  447. MOVE.L A6,-(A7)
  448. MOVE.L lock,D1
  449. MOVE.L parameterBlock,D2
  450. MOVEA.L _DOSBase,A6
  451. JSR -114(A6)
  452. MOVEA.L (A7)+,A6
  453. TST.L D0
  454. BEQ.B @end
  455. MOVE.B #1,D0
  456. @end:
  457. MOVE.B D0,@RESULT
  458. END;
  459. END;
  460. FUNCTION NameFromLock(lock : BPTR; buffer : pCHAR; len : LONGINT) : BOOLEAN;
  461. BEGIN
  462. ASM
  463. MOVE.L A6,-(A7)
  464. MOVE.L lock,D1
  465. MOVE.L buffer,D2
  466. MOVE.L len,D3
  467. MOVEA.L _DOSBase,A6
  468. JSR -402(A6)
  469. MOVEA.L (A7)+,A6
  470. TST.L D0
  471. BEQ.B @end
  472. MOVE.B #1,D0
  473. @end: MOVE.B D0,@RESULT
  474. END;
  475. END;
  476. FUNCTION GetVar(name : pCHAR; buffer : pCHAR; size : LONGINT; flags : LONGINT) : LONGINT;
  477. BEGIN
  478. ASM
  479. MOVE.L A6,-(A7)
  480. MOVE.L name,D1
  481. MOVE.L buffer,D2
  482. MOVE.L size,D3
  483. MOVE.L flags,D4
  484. MOVEA.L _DOSBase,A6
  485. JSR -906(A6)
  486. MOVEA.L (A7)+,A6
  487. MOVE.L D0,@RESULT
  488. END;
  489. END;
  490. FUNCTION FindTask(name : pCHAR) : pTask;
  491. BEGIN
  492. ASM
  493. MOVE.L A6,-(A7)
  494. MOVEA.L name,A1
  495. MOVEA.L _ExecBase,A6
  496. JSR -294(A6)
  497. MOVEA.L (A7)+,A6
  498. MOVE.L D0,@RESULT
  499. END;
  500. END;
  501. FUNCTION MatchFirst(pat : pCHAR; anchor : pAnchorPath) : LONGINT;
  502. BEGIN
  503. ASM
  504. MOVE.L A6,-(A7)
  505. MOVE.L pat,D1
  506. MOVE.L anchor,D2
  507. MOVEA.L _DOSBase,A6
  508. JSR -822(A6)
  509. MOVEA.L (A7)+,A6
  510. MOVE.L D0,@RESULT
  511. END;
  512. END;
  513. FUNCTION MatchNext(anchor : pAnchorPath) : LONGINT;
  514. BEGIN
  515. ASM
  516. MOVE.L A6,-(A7)
  517. MOVE.L anchor,D1
  518. MOVEA.L _DOSBase,A6
  519. JSR -828(A6)
  520. MOVEA.L (A7)+,A6
  521. MOVE.L D0,@RESULT
  522. END;
  523. END;
  524. PROCEDURE MatchEnd(anchor : pAnchorPath);
  525. BEGIN
  526. ASM
  527. MOVE.L A6,-(A7)
  528. MOVE.L anchor,D1
  529. MOVEA.L _DOSBase,A6
  530. JSR -834(A6)
  531. MOVEA.L (A7)+,A6
  532. END;
  533. END;
  534. FUNCTION Cli : pCommandLineInterface;
  535. BEGIN
  536. ASM
  537. MOVE.L A6,-(A7)
  538. MOVEA.L _DOSBase,A6
  539. JSR -492(A6)
  540. MOVEA.L (A7)+,A6
  541. MOVE.L D0,@RESULT
  542. END;
  543. END;
  544. Function _Execute(p: pchar): longint;
  545. Begin
  546. asm
  547. move.l a6,d6 { save base pointer }
  548. move.l d2,-(sp)
  549. move.l p,d1 { command to execute }
  550. clr.l d2 { No TagList for command }
  551. move.l _DosBase,a6
  552. jsr _LVOSystemTagList(a6)
  553. move.l (sp)+,d2
  554. move.l d6,a6 { restore base pointer }
  555. move.l d0,@RESULT
  556. end;
  557. end;
  558. FUNCTION LockDosList(flags : CARDINAL) : pDosList;
  559. BEGIN
  560. ASM
  561. MOVE.L A6,-(A7)
  562. MOVE.L flags,D1
  563. MOVEA.L _DOSBase,A6
  564. JSR -654(A6)
  565. MOVEA.L (A7)+,A6
  566. MOVE.L D0,@RESULT
  567. END;
  568. END;
  569. PROCEDURE UnLockDosList(flags : CARDINAL);
  570. BEGIN
  571. ASM
  572. MOVE.L A6,-(A7)
  573. MOVE.L flags,D1
  574. MOVEA.L _DOSBase,A6
  575. JSR -660(A6)
  576. MOVEA.L (A7)+,A6
  577. END;
  578. END;
  579. FUNCTION NextDosEntry(dlist : pDosList; flags : CARDINAL) : pDosList;
  580. BEGIN
  581. ASM
  582. MOVE.L A6,-(A7)
  583. MOVE.L dlist,D1
  584. MOVE.L flags,D2
  585. MOVEA.L _DOSBase,A6
  586. JSR -690(A6)
  587. MOVEA.L (A7)+,A6
  588. MOVE.L D0,@RESULT
  589. END;
  590. END;
  591. FUNCTION BADDR(bval : BPTR): POINTER;
  592. BEGIN
  593. BADDR := POINTER( bval shl 2);
  594. END;
  595. function PasToC(var s: string): Pchar;
  596. var i: integer;
  597. begin
  598. i := Length(s) + 1;
  599. if i > 255 then
  600. begin
  601. Delete(s, 255, 1); { ensure there is a spare byte }
  602. Dec(i)
  603. end;
  604. s[i] := #0;
  605. PasToC := @s[1]
  606. end;
  607. Procedure AmigaToDt(SecsPast: LongInt; Var Dt: DateTime);
  608. var
  609. cd : pClockData;
  610. Begin
  611. New(cd);
  612. Amiga2Date(SecsPast,cd);
  613. Dt.sec := cd^.sec;
  614. Dt.min := cd^.min;
  615. Dt.hour := cd^.hour;
  616. Dt.day := cd^.mday;
  617. Dt.month := cd^.month;
  618. Dt.year := cd^.year;
  619. Dispose(cd);
  620. End;
  621. Function DtToAmiga(DT: DateTime): LongInt;
  622. var
  623. cd : pClockData;
  624. temp : Longint;
  625. Begin
  626. New(cd);
  627. cd^.sec := Dt.sec;
  628. cd^.min := Dt.min;
  629. cd^.hour := Dt.hour;
  630. cd^.mday := Dt.day;
  631. cd^.month := Dt.month;
  632. cd^.year := Dt.year;
  633. temp := Date2Amiga(cd);
  634. Dispose(cd);
  635. DtToAmiga := temp;
  636. end;
  637. Function SetProtection(const name: string; mask:longint): longint;
  638. var
  639. buffer : array[0..255] of char;
  640. Begin
  641. move(name[1],buffer,length(name));
  642. buffer[length(name)]:=#0;
  643. asm
  644. move.l a6,d6
  645. lea buffer,a0
  646. move.l a0,d1
  647. move.l mask,d2
  648. move.l _DosBase,a6
  649. jsr -186(a6)
  650. move.l d6,a6
  651. move.l d0,@RESULT
  652. end;
  653. end;
  654. Function IsLeapYear(Source : Word) : Boolean;
  655. Begin
  656. If (Source Mod 4 = 0) Then
  657. IsLeapYear := True
  658. Else
  659. IsLeapYear := False;
  660. End;
  661. Procedure Amiga2DateStamp(Date : LongInt; Var TotalDays,Minutes,Ticks: longint);
  662. { Converts a value in seconds past 1978 to a value in AMIGA DateStamp format }
  663. { Taken from SWAG and modified to work with the Amiga format - CEC }
  664. Var
  665. LocalDate : LongInt; Done : Boolean; X : ShortInt; TotDays : Integer;
  666. Y: Word;
  667. M: Word;
  668. D: Word;
  669. H: Word;
  670. Min: Word;
  671. S : Word;
  672. Begin
  673. Y := 1978; M := 1; D := 1; H := 0; Min := 0; S := 0;
  674. TotalDays := 0;
  675. Minutes := 0;
  676. Ticks := 0;
  677. LocalDate := Date;
  678. Done := False;
  679. While Not Done Do
  680. Begin
  681. If LocalDate >= SecsPerYear Then
  682. Begin
  683. Inc(Y,1);
  684. Dec(LocalDate,SecsPerYear);
  685. Inc(TotalDays,DaysPerYear[12]);
  686. End
  687. Else
  688. Done := True;
  689. If (IsLeapYear(Y+1)) And (LocalDate >= SecsPerLeapYear) And
  690. (Not Done) Then
  691. Begin
  692. Inc(Y,1);
  693. Dec(LocalDate,SecsPerLeapYear);
  694. Inc(TotalDays,DaysPerLeapYear[12]);
  695. End;
  696. End; { END WHILE }
  697. M := 1; D := 1;
  698. Done := False;
  699. TotDays := LocalDate Div SecsPerDay;
  700. { Total number of days }
  701. TotalDays := TotalDays + TotDays;
  702. Dec(LocalDate,TotDays*SecsPerDay);
  703. { Absolute hours since start of day }
  704. H := LocalDate Div SecsPerHour;
  705. { Convert to minutes }
  706. Minutes := H*60;
  707. Dec(LocalDate,(H * SecsPerHour));
  708. { Find the remaining minutes to add }
  709. Min := LocalDate Div SecsPerMinute;
  710. Dec(LocalDate,(Min * SecsPerMinute));
  711. Minutes:=Minutes+Min;
  712. { Find the number of seconds and convert to ticks }
  713. S := LocalDate;
  714. Ticks:=TICKSPERSECOND*S;
  715. End;
  716. Function SetFileDate(name: string; p : pDateStamp): longint;
  717. var
  718. buffer : array[0..255] of char;
  719. Begin
  720. move(name[1],buffer,length(name));
  721. buffer[length(name)]:=#0;
  722. asm
  723. move.l a6,d6 { save base pointer }
  724. move.l d2,-(sp) { save reserved reg }
  725. lea buffer,a0
  726. move.l a0,d1
  727. move.l p,d2
  728. move.l _DosBase,a6
  729. jsr _LVOSetFileDate(a6)
  730. move.l (sp)+,d2 { restore reserved reg }
  731. move.l d6,a6 { restore base pointer }
  732. move.l d0,@Result
  733. end;
  734. end;
  735. {******************************************************************************
  736. --- Dos Interrupt ---
  737. ******************************************************************************}
  738. (*Procedure Intr (intno: byte; var regs: registers);
  739. Begin
  740. { Does not apply to Linux - not implemented }
  741. End;*)
  742. Procedure SwapVectors;
  743. Begin
  744. { Does not apply to Linux - Do Nothing }
  745. End;
  746. (*Procedure msdos(var regs : registers);
  747. Begin
  748. { ! Not implemented in Linux ! }
  749. End;*)
  750. Procedure getintvec(intno : byte;var vector : pointer);
  751. Begin
  752. { ! Not implemented in Linux ! }
  753. End;
  754. Procedure setintvec(intno : byte;vector : pointer);
  755. Begin
  756. { ! Not implemented in Linux ! }
  757. End;
  758. {******************************************************************************
  759. --- Info / Date / Time ---
  760. ******************************************************************************}
  761. Function DosVersion: Word;
  762. var p: pLibrary;
  763. Begin
  764. p:=pLibrary(_DosBase);
  765. DosVersion:= p^.lib_Version or (p^.lib_Revision shl 8);
  766. End;
  767. Procedure GetDate(Var Year, Month, MDay, WDay: Word);
  768. Var
  769. cd : pClockData;
  770. mysec,
  771. tick : Longint;
  772. begin
  773. New(cd);
  774. CurrentTime(mysec,tick);
  775. Amiga2Date(mysec,cd);
  776. Year := cd^.year;
  777. Month := cd^.month;
  778. MDay := cd^.mday;
  779. WDay := cd^.wday;
  780. Dispose(cd);
  781. end;
  782. Procedure SetDate(Year, Month, Day: Word);
  783. Begin
  784. { !! }
  785. End;
  786. Procedure GetTime(Var Hour, Minute, Second, Sec100: Word);
  787. Var
  788. mysec,
  789. tick : Longint;
  790. cd : pClockData;
  791. begin
  792. New(cd);
  793. CurrentTime(mysec,tick);
  794. Amiga2Date(mysec,cd);
  795. Hour := cd^.hour;
  796. Minute := cd^.min;
  797. Second := cd^.sec;
  798. Sec100 := 0;
  799. Dispose(cd);
  800. END;
  801. Procedure SetTime(Hour, Minute, Second, Sec100: Word);
  802. Begin
  803. { !! }
  804. End;
  805. Procedure unpacktime(p : longint;var t : datetime);
  806. Begin
  807. AmigaToDt(p,t);
  808. End;
  809. Procedure packtime(var t : datetime;var p : longint);
  810. Begin
  811. p := DtToAmiga(t);
  812. end;
  813. {******************************************************************************
  814. --- Exec ---
  815. ******************************************************************************}
  816. Var
  817. LastDosExitCode: word;
  818. breakflag : Boolean;
  819. ver: Boolean;
  820. Procedure Exec (Const Path: PathStr; Const ComLine: ComStr);
  821. var
  822. p : string;
  823. buf: array[0..255] of char;
  824. result : longint;
  825. MyLock : longint;
  826. i : Integer;
  827. Begin
  828. DosError := 0;
  829. LastdosExitCode := 0;
  830. p:=Path+' '+ComLine;
  831. { allow backslash as slash }
  832. for i:=1 to length(p) do
  833. if p[i]='\' then p[i]:='/';
  834. Move(p[1],buf,length(p));
  835. buf[Length(p)]:=#0;
  836. { Here we must first check if the command we wish to execute }
  837. { actually exists, because this is NOT handled by the }
  838. { _SystemTagList call (program will abort!!) }
  839. { Try to open with shared lock }
  840. MyLock:=Lock(path,SHARED_LOCK);
  841. if MyLock <> 0 then
  842. Begin
  843. { File exists - therefore unlock it }
  844. Unlock(MyLock);
  845. result:=_Execute(buf);
  846. { on return of -1 the shell could not be executed }
  847. { probably because there was not enough memory }
  848. if result = -1 then
  849. DosError:=8
  850. else
  851. LastDosExitCode:=word(result);
  852. end
  853. else
  854. DosError:=3;
  855. End;
  856. Function DosExitCode: Word;
  857. Begin
  858. DosExitCode:=LastdosExitCode;
  859. End;
  860. Procedure GetCBreak(Var BreakValue: Boolean);
  861. Begin
  862. breakvalue:=breakflag;
  863. End;
  864. Procedure SetCBreak(BreakValue: Boolean);
  865. Begin
  866. breakflag:=BreakValue;
  867. End;
  868. Procedure GetVerify(Var Verify: Boolean);
  869. Begin
  870. verify:=ver;
  871. End;
  872. Procedure SetVerify(Verify: Boolean);
  873. Begin
  874. ver:=Verify;
  875. End;
  876. {******************************************************************************
  877. --- Disk ---
  878. ******************************************************************************}
  879. { How to solve the problem with this: }
  880. { We could walk through the device list }
  881. { at startup to determine possible devices }
  882. const
  883. not_to_use_devs : array[0..12] of string =(
  884. 'DF0:',
  885. 'DF1:',
  886. 'DF2:',
  887. 'DF3:',
  888. 'PED:',
  889. 'PRJ:',
  890. 'PIPE:',
  891. 'RAM:',
  892. 'CON:',
  893. 'RAW:',
  894. 'SER:',
  895. 'PAR:',
  896. 'PRT:');
  897. var
  898. deviceids : array[1..20] of byte;
  899. devicenames : array[1..20] of string[20];
  900. numberofdevices : Byte;
  901. Function DiskFree(Drive: Byte): Longint;
  902. Var
  903. MyLock : BPTR;
  904. Inf : pInfoData;
  905. Free : Longint;
  906. myproc : pProcess;
  907. OldWinPtr : Pointer;
  908. Begin
  909. Free := -1;
  910. { Here we stop systemrequesters to appear }
  911. myproc := pProcess(FindTask(nil));
  912. OldWinPtr := myproc^.pr_WindowPtr;
  913. myproc^.pr_WindowPtr := Pointer(-1);
  914. { End of systemrequesterstop }
  915. New(Inf);
  916. MyLock := Lock(devicenames[deviceids[Drive]],SHARED_LOCK);
  917. If MyLock <> 0 then begin
  918. if Info(MyLock,Inf) then begin
  919. Free := (Inf^.id_NumBlocks * Inf^.id_BytesPerBlock) -
  920. (Inf^.id_NumBlocksUsed * Inf^.id_BytesPerBlock);
  921. end;
  922. Unlock(MyLock);
  923. end;
  924. Dispose(Inf);
  925. { Restore systemrequesters }
  926. myproc^.pr_WindowPtr := OldWinPtr;
  927. diskfree := Free;
  928. end;
  929. Function DiskSize(Drive: Byte): Longint;
  930. Var
  931. MyLock : BPTR;
  932. Inf : pInfoData;
  933. Size : Longint;
  934. myproc : pProcess;
  935. OldWinPtr : Pointer;
  936. Begin
  937. Size := -1;
  938. { Here we stop systemrequesters to appear }
  939. myproc := pProcess(FindTask(nil));
  940. OldWinPtr := myproc^.pr_WindowPtr;
  941. myproc^.pr_WindowPtr := Pointer(-1);
  942. { End of systemrequesterstop }
  943. New(Inf);
  944. MyLock := Lock(devicenames[deviceids[Drive]],SHARED_LOCK);
  945. If MyLock <> 0 then begin
  946. if Info(MyLock,Inf) then begin
  947. Size := (Inf^.id_NumBlocks * Inf^.id_BytesPerBlock);
  948. end;
  949. Unlock(MyLock);
  950. end;
  951. Dispose(Inf);
  952. { Restore systemrequesters }
  953. myproc^.pr_WindowPtr := OldWinPtr;
  954. disksize := Size;
  955. end;
  956. Procedure FindFirst(Path: PathStr; Attr: Word; Var f: SearchRec);
  957. var
  958. buf: Array[0..255] of char;
  959. Anchor : pAnchorPath;
  960. Result : Longint;
  961. index : Integer;
  962. s : string;
  963. j : integer;
  964. Begin
  965. DosError:=0;
  966. New(Anchor);
  967. {----- allow backslash as slash -----}
  968. for index:=1 to length(path) do
  969. if path[index]='\' then path[index]:='/';
  970. { remove any dot characters and replace by their current }
  971. { directory equivalent. }
  972. if pos('../',path) = 1 then
  973. { look for parent directory }
  974. Begin
  975. delete(path,1,3);
  976. getdir(0,s);
  977. j:=length(s);
  978. while (s[j] <> '/') AND (s[j] <> ':') AND (j > 0 ) do
  979. dec(j);
  980. if j > 0 then
  981. s:=copy(s,1,j);
  982. path:=s+path;
  983. end
  984. else
  985. if pos('./',path) = 1 then
  986. { look for current directory }
  987. Begin
  988. delete(path,1,2);
  989. getdir(0,s);
  990. if (s[length(s)] <> '/') and (s[length(s)] <> ':') then
  991. s:=s+'/';
  992. path:=s+path;
  993. end;
  994. {----- replace * by #? AmigaOs strings -----}
  995. repeat
  996. index:= pos('*',Path);
  997. if index <> 0 then
  998. Begin
  999. delete(Path,index,1);
  1000. insert('#?',Path,index);
  1001. end;
  1002. until index =0;
  1003. {--------------------------------------------}
  1004. FillChar(Anchor^,sizeof(TAnchorPath),#0);
  1005. move(path[1],buf,length(path));
  1006. buf[length(path)]:=#0;
  1007. Result:=MatchFirst(@buf,Anchor);
  1008. f.AnchorPtr:=Anchor;
  1009. if Result = ERROR_NO_MORE_ENTRIES then
  1010. DosError:=18
  1011. else
  1012. if Result <> 0 then
  1013. DosError:=3;
  1014. { If there is an error, deallocate }
  1015. { the anchorpath structure }
  1016. if DosError <> 0 then
  1017. Begin
  1018. MatchEnd(Anchor);
  1019. if assigned(Anchor) then
  1020. Dispose(Anchor);
  1021. end
  1022. else
  1023. {-------------------------------------------------------------------}
  1024. { Here we fill up the SearchRec attribute, but we also do check }
  1025. { something else, if the it does not match the mask we are looking }
  1026. { for we should go to the next file or directory. }
  1027. {-------------------------------------------------------------------}
  1028. Begin
  1029. with Anchor^.ap_Info do
  1030. Begin
  1031. f.Time := fib_Date.ds_Days * (24 * 60 * 60) +
  1032. fib_Date.ds_Minute * 60 +
  1033. fib_Date.ds_Tick div 50;
  1034. {*------------------------------------*}
  1035. {* Determine if is a file or a folder *}
  1036. {*------------------------------------*}
  1037. if fib_DirEntryType > 0 then
  1038. f.attr:=f.attr OR DIRECTORY;
  1039. {*------------------------------------*}
  1040. {* Determine if Read only *}
  1041. {* Readonly if R flag on and W flag *}
  1042. {* off. *}
  1043. {* Should we check also that EXEC *}
  1044. {* is zero? for read only? *}
  1045. {*------------------------------------*}
  1046. if ((fib_Protection and FIBF_READ) <> 0)
  1047. AND ((fib_Protection and FIBF_WRITE) = 0)
  1048. then
  1049. f.attr:=f.attr or READONLY;
  1050. f.Name := strpas(fib_FileName);
  1051. f.Size := fib_Size;
  1052. end; { end with }
  1053. end;
  1054. End;
  1055. Procedure FindNext(Var f: SearchRec);
  1056. var
  1057. Result: longint;
  1058. Anchor : pAnchorPath;
  1059. Begin
  1060. DosError:=0;
  1061. Result:=MatchNext(f.AnchorPtr);
  1062. if Result = ERROR_NO_MORE_ENTRIES then
  1063. DosError:=18
  1064. else
  1065. if Result <> 0 then
  1066. DosError:=3;
  1067. { If there is an error, deallocate }
  1068. { the anchorpath structure }
  1069. if DosError <> 0 then
  1070. Begin
  1071. MatchEnd(f.AnchorPtr);
  1072. if assigned(f.AnchorPtr) then
  1073. Dispose(f.AnchorPtr);
  1074. end
  1075. else
  1076. { Fill up the Searchrec information }
  1077. { and also check if the files are with }
  1078. { the correct attributes }
  1079. Begin
  1080. Anchor:=pAnchorPath(f.AnchorPtr);
  1081. with Anchor^.ap_Info do
  1082. Begin
  1083. f.Time := fib_Date.ds_Days * (24 * 60 * 60) +
  1084. fib_Date.ds_Minute * 60 +
  1085. fib_Date.ds_Tick div 50;
  1086. {*------------------------------------*}
  1087. {* Determine if is a file or a folder *}
  1088. {*------------------------------------*}
  1089. if fib_DirEntryType > 0 then
  1090. f.attr:=f.attr OR DIRECTORY;
  1091. {*------------------------------------*}
  1092. {* Determine if Read only *}
  1093. {* Readonly if R flag on and W flag *}
  1094. {* off. *}
  1095. {* Should we check also that EXEC *}
  1096. {* is zero? for read only? *}
  1097. {*------------------------------------*}
  1098. if ((fib_Protection and FIBF_READ) <> 0)
  1099. AND ((fib_Protection and FIBF_WRITE) = 0)
  1100. then
  1101. f.attr:=f.attr or READONLY;
  1102. f.Name := strpas(fib_FileName);
  1103. f.Size := fib_Size;
  1104. end; { end with }
  1105. end;
  1106. End;
  1107. Procedure FindClose(Var f: SearchRec);
  1108. begin
  1109. end;
  1110. {******************************************************************************
  1111. --- File ---
  1112. ******************************************************************************}
  1113. Procedure FSplit(path: pathstr; var dir: dirstr; var name: namestr; var ext: extstr);
  1114. var
  1115. I: Word;
  1116. begin
  1117. { allow backslash as slash }
  1118. for i:=1 to length(path) do
  1119. if path[i]='\' then path[i]:='/';
  1120. I := Length(Path);
  1121. while (I > 0) and not ((Path[I] = '/') or (Path[I] = ':'))
  1122. do Dec(I);
  1123. if Path[I] = '/' then
  1124. dir := Copy(Path, 0, I)
  1125. else dir := Copy(Path,0,I);
  1126. if Length(Path) > Length(dir) then
  1127. name := Copy(Path, I + 1, Length(Path)-I)
  1128. else
  1129. name := '';
  1130. { Remove extension }
  1131. if pos('.',name) <> 0 then
  1132. delete(name,pos('.',name),length(name));
  1133. I := Pos('.',Path);
  1134. if I > 0 then
  1135. ext := Copy(Path,I,Length(Path)-(I-1))
  1136. else ext := '';
  1137. end;
  1138. Function FExpand(Path: PathStr): PathStr;
  1139. var
  1140. FLock : BPTR;
  1141. buffer : array[0..255] of char;
  1142. i :integer;
  1143. j :integer;
  1144. temp : string;
  1145. begin
  1146. { allow backslash as slash }
  1147. for i:=1 to length(path) do
  1148. if path[i]='\' then path[i]:='/';
  1149. temp:=path;
  1150. if pos('../',temp) = 1 then
  1151. delete(temp,1,3);
  1152. if pos('./',temp) = 1 then
  1153. delete(temp,1,2);
  1154. {First remove all references to '/./'}
  1155. while pos('/./',temp)<>0 do
  1156. delete(temp,pos('/./',temp),3);
  1157. {Now remove also all references to '/../' + of course previous dirs..}
  1158. repeat
  1159. i:=pos('/../',temp);
  1160. {Find the pos of the previous dir}
  1161. if i>1 then
  1162. begin
  1163. j:=i-1;
  1164. while (j>1) and (temp[j]<>'/') do
  1165. dec (j);{temp[1] is always '/'}
  1166. delete(temp,j,i-j+4);
  1167. end
  1168. else
  1169. if i=1 then {i=1, so we have temp='/../something', just delete '/../'}
  1170. delete(temp,1,4);
  1171. until i=0;
  1172. FLock := Lock(temp,-2);
  1173. if FLock <> 0 then begin
  1174. if NameFromLock(FLock,buffer,255) then begin
  1175. Unlock(FLock);
  1176. FExpand := strpas(buffer);
  1177. end else begin
  1178. Unlock(FLock);
  1179. FExpand := '';
  1180. end;
  1181. end else FExpand := '';
  1182. end;
  1183. Function fsearch(path : pathstr;dirlist : string) : pathstr;
  1184. var
  1185. i,p1 : longint;
  1186. s : searchrec;
  1187. newdir : pathstr;
  1188. begin
  1189. { No wildcards allowed in these things }
  1190. if (pos('?',path)<>0) or (pos('*',path)<>0) then
  1191. fsearch:=''
  1192. else
  1193. begin
  1194. { allow slash as backslash }
  1195. for i:=1 to length(dirlist) do
  1196. if dirlist[i]='\' then dirlist[i]:='/';
  1197. repeat
  1198. p1:=pos(';',dirlist);
  1199. if p1<>0 then
  1200. begin
  1201. newdir:=copy(dirlist,1,p1-1);
  1202. delete(dirlist,1,p1);
  1203. end
  1204. else
  1205. begin
  1206. newdir:=dirlist;
  1207. dirlist:='';
  1208. end;
  1209. if (newdir<>'') and (not (newdir[length(newdir)] in ['/',':'])) then
  1210. newdir:=newdir+'/';
  1211. findfirst(newdir+path,anyfile,s);
  1212. if doserror=0 then
  1213. newdir:=newdir+path
  1214. else
  1215. newdir:='';
  1216. until (dirlist='') or (newdir<>'');
  1217. fsearch:=newdir;
  1218. end;
  1219. end;
  1220. Procedure getftime (var f; var time : longint);
  1221. {
  1222. This function returns a file's date and time as the number of
  1223. seconds after January 1, 1978 that the file was created.
  1224. }
  1225. var
  1226. FInfo : pFileInfoBlock;
  1227. FTime : Longint;
  1228. FLock : Longint;
  1229. Str : String;
  1230. i : integer;
  1231. begin
  1232. DosError:=0;
  1233. FTime := 0;
  1234. Str := StrPas(filerec(f).name);
  1235. for i:=1 to length(Str) do
  1236. if str[i]='\' then str[i]:='/';
  1237. FLock := Lock(Str, SHARED_LOCK);
  1238. IF FLock <> 0 then begin
  1239. New(FInfo);
  1240. if Examine(FLock, FInfo) then begin
  1241. with FInfo^.fib_Date do
  1242. FTime := ds_Days * (24 * 60 * 60) +
  1243. ds_Minute * 60 +
  1244. ds_Tick div 50;
  1245. end else begin
  1246. FTime := 0;
  1247. end;
  1248. Unlock(FLock);
  1249. Dispose(FInfo);
  1250. end
  1251. else
  1252. DosError:=6;
  1253. time := FTime;
  1254. end;
  1255. Procedure setftime(var f; time : longint);
  1256. var
  1257. DateStamp: pDateStamp;
  1258. Str: String;
  1259. i: Integer;
  1260. Days, Minutes,Ticks: longint;
  1261. FLock: longint;
  1262. Begin
  1263. new(DateStamp);
  1264. Str := StrPas(filerec(f).name);
  1265. for i:=1 to length(Str) do
  1266. if str[i]='\' then str[i]:='/';
  1267. { Check first of all, if file exists }
  1268. FLock := Lock(Str, SHARED_LOCK);
  1269. IF FLock <> 0 then
  1270. begin
  1271. Unlock(FLock);
  1272. Amiga2DateStamp(time,Days,Minutes,ticks);
  1273. DateStamp^.ds_Days:=Days;
  1274. DateStamp^.ds_Minute:=Minutes;
  1275. DateStamp^.ds_Tick:=Ticks;
  1276. if SetFileDate(Str,DateStamp) <> 0 then
  1277. DosError:=0
  1278. else
  1279. DosError:=6;
  1280. end
  1281. else
  1282. DosError:=2;
  1283. if assigned(DateStamp) then Dispose(DateStamp);
  1284. End;
  1285. Procedure getfattr(var f; var attr : word);
  1286. var
  1287. info : pFileInfoBlock;
  1288. MyLock : Longint;
  1289. flags: word;
  1290. Str: String;
  1291. i: integer;
  1292. Begin
  1293. DosError:=0;
  1294. flags:=0;
  1295. New(info);
  1296. Str := StrPas(filerec(f).name);
  1297. for i:=1 to length(Str) do
  1298. if str[i]='\' then str[i]:='/';
  1299. { open with shared lock to check if file exists }
  1300. MyLock:=Lock(Str,SHARED_LOCK);
  1301. if MyLock <> 0 then
  1302. Begin
  1303. Examine(MyLock,info);
  1304. {*------------------------------------*}
  1305. {* Determine if is a file or a folder *}
  1306. {*------------------------------------*}
  1307. if info^.fib_DirEntryType > 0 then
  1308. flags:=flags OR DIRECTORY;
  1309. {*------------------------------------*}
  1310. {* Determine if Read only *}
  1311. {* Readonly if R flag on and W flag *}
  1312. {* off. *}
  1313. {* Should we check also that EXEC *}
  1314. {* is zero? for read only? *}
  1315. {*------------------------------------*}
  1316. if ((info^.fib_Protection and FIBF_READ) <> 0)
  1317. AND ((info^.fib_Protection and FIBF_WRITE) = 0)
  1318. then
  1319. flags:=flags OR ReadOnly;
  1320. Unlock(mylock);
  1321. end
  1322. else
  1323. DosError:=3;
  1324. attr:=flags;
  1325. Dispose(info);
  1326. End;
  1327. Procedure setfattr (var f;attr : word);
  1328. var
  1329. flags: longint;
  1330. MyLock : longint;
  1331. str: string;
  1332. i: integer;
  1333. Begin
  1334. DosError:=0;
  1335. flags:=FIBF_WRITE;
  1336. { open with shared lock }
  1337. Str := StrPas(filerec(f).name);
  1338. for i:=1 to length(Str) do
  1339. if str[i]='\' then str[i]:='/';
  1340. MyLock:=Lock(Str,SHARED_LOCK);
  1341. { By default files are read-write }
  1342. if attr AND ReadOnly <> 0 then
  1343. { Clear the Fibf_write flags }
  1344. flags:=FIBF_READ;
  1345. if MyLock <> 0 then
  1346. Begin
  1347. Unlock(MyLock);
  1348. if SetProtection(Str,flags) = 0 then
  1349. DosError:=5;
  1350. end
  1351. else
  1352. DosError:=3;
  1353. End;
  1354. {******************************************************************************
  1355. --- Environment ---
  1356. ******************************************************************************}
  1357. Function EnvCount: Longint;
  1358. { HOW TO GET THIS VALUE: }
  1359. { Each time this function is called, we look at the }
  1360. { local variables in the Process structure (2.0+) }
  1361. { And we also read all files in the ENV: directory }
  1362. Begin
  1363. End;
  1364. Function EnvStr(Index: Integer): String;
  1365. Begin
  1366. EnvStr:='';
  1367. End;
  1368. function GetEnv(envvar : String): String;
  1369. var
  1370. buffer : Pchar;
  1371. bufarr : array[0..255] of char;
  1372. strbuffer : array[0..255] of char;
  1373. temp : Longint;
  1374. begin
  1375. move(envvar[1],strbuffer,length(envvar));
  1376. strbuffer[length(envvar)] := #0;
  1377. buffer := @bufarr;
  1378. temp := GetVar(strbuffer,buffer,255,$100);
  1379. if temp = -1 then
  1380. GetEnv := ''
  1381. else GetEnv := StrPas(buffer);
  1382. end;
  1383. {******************************************************************************
  1384. --- Not Supported ---
  1385. ******************************************************************************}
  1386. Procedure keep(exitcode : word);
  1387. Begin
  1388. { ! Not implemented in Linux ! }
  1389. End;
  1390. procedure AddDevice(str : String);
  1391. begin
  1392. inc(numberofdevices);
  1393. deviceids[numberofdevices] := numberofdevices;
  1394. devicenames[numberofdevices] := str;
  1395. end;
  1396. function MakeDeviceName(str : pchar): string;
  1397. var
  1398. temp : string[20];
  1399. begin
  1400. temp := strpas(str);
  1401. temp := temp + ':';
  1402. MakeDeviceName := temp;
  1403. end;
  1404. function IsInDeviceList(str : string): boolean;
  1405. var
  1406. i : byte;
  1407. theresult : boolean;
  1408. begin
  1409. theresult := false;
  1410. for i := low(not_to_use_devs) to high(not_to_use_devs) do
  1411. begin
  1412. if str = not_to_use_devs[i] then begin
  1413. theresult := true;
  1414. break;
  1415. end;
  1416. end;
  1417. IsInDeviceList := theresult;
  1418. end;
  1419. function BSTR2STRING(s : BSTR): pchar;
  1420. begin
  1421. BSTR2STRING := Pointer(Longint(BADDR(s))+1);
  1422. end;
  1423. procedure ReadInDevices;
  1424. var
  1425. dl : pDosList;
  1426. temp : pchar;
  1427. str : string[20];
  1428. begin
  1429. dl := LockDosList(LDF_DEVICES or LDF_READ );
  1430. repeat
  1431. dl := NextDosEntry(dl,LDF_DEVICES );
  1432. if dl <> nil then begin
  1433. temp := BSTR2STRING(dl^.dol_Name);
  1434. str := MakeDeviceName(temp);
  1435. if not IsInDeviceList(str) then
  1436. AddDevice(str);
  1437. end;
  1438. until dl = nil;
  1439. UnLockDosList(LDF_DEVICES or LDF_READ );
  1440. end;
  1441. Begin
  1442. DosError:=0;
  1443. ver:=TRUE;
  1444. breakflag:=TRUE;
  1445. numberofdevices := 0;
  1446. AddDevice('DF0:');
  1447. AddDevice('DF1:');
  1448. AddDevice('DF2:');
  1449. AddDevice('DF3:');
  1450. ReadInDevices;
  1451. End.
  1452. {
  1453. $Log$
  1454. Revision 1.8 1998-08-19 14:52:52 carl
  1455. * SearchRec was not aligned!! so BOUM!...
  1456. Revision 1.7 1998/08/17 12:30:42 carl
  1457. * FExpand removes dot characters
  1458. * Findfirst single/double dot expansion
  1459. + SetFtime implemented
  1460. Revision 1.6 1998/08/13 13:18:45 carl
  1461. * FSearch bugfix
  1462. * FSplit bugfix
  1463. + GetFAttr,SetFAttr and GetFTime accept dos dir separators
  1464. Revision 1.5 1998/08/04 13:37:10 carl
  1465. * bugfix of findfirst, was not convberting correctl backslahes
  1466. History (Nils Sjoholm):
  1467. 10.02.1998 First version for Amiga.
  1468. Just GetDate and GetTime.
  1469. 11.02.1998 Added AmigaToDt and DtToAmiga
  1470. Changed GetDate and GetTime to
  1471. use AmigaToDt and DtToAmiga.
  1472. Added DiskSize and DiskFree.
  1473. They are using a string as arg
  1474. have to try to fix that.
  1475. 12.02.1998 Added Fsplit and FExpand.
  1476. Cleaned up the unit and removed
  1477. stuff that was not used yet.
  1478. 13.02.1998 Added CToPas and PasToC and removed
  1479. the uses of strings.
  1480. 14.02.1998 Removed AmigaToDt and DtToAmiga
  1481. from public area.
  1482. Added deviceids and devicenames
  1483. arrays so now diskfree and disksize
  1484. is compatible with dos.
  1485. }