home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 17 / CD_ASCQ_17_101194.iso / vrac / ptgenr2.zip / BBFILE.PAS < prev    next >
Pascal/Delphi Source File  |  1994-08-01  |  20KB  |  288 lines
  1. (* This file was mangled by Mangler 1.32 (c) Copyright 1993-1994 by Berend de Boer *)
  2. { Created : 18-01-91
  3.  
  4.   This unit implementents an interface such as the dos command.com. Use it
  5.   for easy copying and erasing one or more files.
  6.   Probably not every dos command line combination is valid! Check the not
  7.   so common ones.
  8.  
  9. Uses string identifiers 1900..1919
  10.  
  11. Last changes :
  12. 91-07-15  Copied from Turbo Pascal 5.5 and adapted to version 6
  13. 92-06-13  Copied some files from BBUTIL
  14.           Added procedure Wipe
  15. 92-10-14  Added function FDefaultExtension
  16.           Added function FForceExtenstion
  17. 92-11-28  Added function OpenFile which opens a file in a specified mode
  18. 93-03-15  Removed language dependency, use a string resource instead
  19.           Added function IOError (removed from BBDlg)
  20. 93-03-24  Added function GetFileName
  21. 93-04-12  Added function GetUniqueFileName
  22.           Changed function SetHandleCount to one that works on dos 3.0+
  23.           with thanks to Bob Swart who posted this code more or less in the
  24.           PASCAL.028 echo
  25. 93-09-11  Added DosMove
  26. 93-09-20  Rewritten DosCopy and DosMove. Added full wildcard support. Added
  27.           better share support.
  28.           DosCopy now uses streams instead of BlockReads.
  29. 93-10-02  Added function FForceDir
  30. 93-10-04  Renamed Touch to DosTouch
  31. 93-10-23  CreateBak rewritten to a procedure
  32. 93-12-03  Added function XParamStr, a more intelligent ParamStr parser
  33. 93-12-20  Added GetTextFileName to return the name of a textfile
  34. 94-01-10  Changed FileExist to use GetFAttr instead of FindFirst. Could
  35.           break code that depended on use of FindFirst!
  36. 94-02-21  Changed GetUniqueFileName. Now a path should be given to create
  37.           the unique file.
  38. 94-05-02  Fixed bug in DosCopy and DosMove when as destination a filename
  39.           was specified
  40.           Added function IsDirectory
  41. 94-05-16  Adapted to the Windows environment
  42. }
  43.  
  44.  
  45.  
  46. {$IFDEF MSDos}
  47. {$D-,F+,O+,R-,Q-,V-}
  48. {$ENDIF}
  49.  
  50. {$I-,S-,X+}
  51. unit BBFile;
  52.  
  53. interface
  54.  
  55. uses {$IFDEF Windows}
  56.      WinDos,
  57.      {$ELSE}
  58.      Dos,
  59.      {$ENDIF}
  60.      Objects;
  61.  
  62.  
  63. {* file mode constants *}
  64.  
  65. const
  66.   fmReadOnly  = $00;
  67.   fmWriteOnly = $01;
  68.   fmCreate    = $01;
  69.   fmReadWrite = $02;
  70.   fmDenyAll   = $10;
  71.   fmDenyWrite = $20;
  72.   fmDenyRead  = $30;
  73.   fmDenyNone  = $40;
  74.   fmNoWait    = $100;
  75.  
  76.  
  77. {* stream open and create constants. Filemode constants can simply added to *}
  78. {* these base values                                                        *}
  79.  
  80. const
  81.   stCreate = $3C00;
  82.   stOpen   = $3D00;
  83.  
  84. type
  85.   TDriveStr = string[2];
  86.  
  87. {$IFDEF Windows}
  88. {* define some types and constants defined in Dos, but not in WinDos *}
  89. {* this to ease porting *}
  90. const
  91.   Archive = faArchive;
  92.  
  93. type
  94.   PathStr = string[79];
  95.   DirStr = string[67];
  96.   NameStr = string[8];
  97.   ExtStr = string[4];
  98.  
  99.   SearchRec = TSearchRec;
  100.  
  101.   DateTime = TDateTime;
  102.  
  103.   FileRec = TFileRec;
  104.  
  105.   Registers = TRegisters;
  106.  
  107.   TextRec = TTextRec;
  108. {$ENDIF}
  109.  
  110.  
  111. {* DOS routines *}
  112.  
  113. procedure DosDel(Path : PathStr);
  114. procedure DosCopy(Source, Destination : PathStr; AHelpCtx : word);
  115. procedure DosMove(const Source : PathStr; Dest : PathStr; AHelpCtx : word);
  116. procedure DosWipe(const Path : PathStr);
  117. procedure DosTouch(const Path : PathStr);
  118.  
  119.  
  120. {* various file functions *}
  121.  
  122. const
  123.   IOErrNum:integer = 0;           {* set by IOError *}
  124.  
  125. procedure CreateBAK(const FileName : PathStr; HelpCtx : word);
  126. function  FCreate(var f : file; AFileMode : word) : integer;
  127. function  FDefaultExtension(const FileName : PathStr; const Ext : ExtStr) : string;
  128. {$IFDEF Windows}
  129. function  FExpand(Path: PathStr): PathStr;
  130. {$ENDIF}
  131. function  FForceExtension(const FileName : PathStr; const Ext : ExtStr) : string;
  132. function  FForceDir(const FileName : PathStr; Dir : DirStr) : string;
  133. function  FileExist(const FileName : PathStr) : Boolean;
  134. function  FileOpen(var f) : Boolean;
  135. function  FOpen(var f : file; AFileMode : word) : integer;
  136. procedure ForEachFile(const Path : PathStr; Attr : word; Action : pointer);
  137. function  GetDrive : TDriveStr;
  138. function  GetFileName(var f : file) : string;
  139. function  GetTextFileName(var t : text) : string;
  140. function  GetUniqueFileName(const Dir : PathStr) : string;
  141. function  IsDirectory(Dir : DirStr) : Boolean;
  142. function  IOError(const s : string; AHelpCtx : word) : Boolean;
  143. function  MatchFileNames(const Source, Dest : PathStr) : string;
  144. procedure SetHandleCount(Handles : word);
  145. procedure SetHandleCountDos3(Handles : word);
  146. procedure XFSplit(const Path : PathStr;
  147.                   var Dir : DirStr;
  148.                   var Name : NameStr;
  149.                   var Ext : ExtStr);
  150. function  XParamStr(Index : word) : string;
  151.  
  152.  
  153.  
  154.  IMPLEMENTATION USES BBUTIL , {$IFDEF DPMI}WINAPI , {$ENDIF}{$IFDEF Debug}ASSERTIONS , {$ENDIF}{$IFDEF Windows}STRINGS ,
  155. WINAPI , {$ENDIF}BBCONST , BBERROR , BBSTRRES , BBGUI ;PROCEDURE DOSDEL (PATH:PATHSTR);PROCEDURE Ol01l1O010
  156. (CONST Ol1O0OOI:PATHSTR);FAR;VAR OIl0:FILE ;BEGIN ASSIGN (OIl0 , Ol1O0OOI );ERASE (OIl0 );IOERROR (Ol1O0OOI , 0 );END ;
  157. BEGIN FOREACHFILE (PATH , ARCHIVE , @ Ol01l1O010 );END ;PROCEDURE DOSCOPY (SOURCE,DESTINATION:PATHSTR;AHELPCTX:WORD);
  158. PROCEDURE O1lIOlO0O1l1 ;VAR OIOOlO1I0l1:BOOLEAN;O1OOlI1IIIOO:BYTE;PROCEDURE O101IlO10I10I (VAR OIOOlO1I0l1:BOOLEAN);
  159. VAR OO01:LONGINT;BEGIN BEEP ;{$IFDEF Windows}OIOOlO1I0l1 := USERANSWER (RSGET1 (SINFORMUSER , O1OOlI1IIIOO + ORD ('A')- 1
  160. ), AHELPCTX )=CMYES ;{$ELSE}IF BBSTRRES.STRINGS =NIL THEN OIOOlO1I0l1 := USERANSWER ('Disk is full. Insert new disk in '+
  161. 'drive '+ CHR (O1OOlI1IIIOO + ORD ('A')- 1 ), 0 )=CMYES ELSE OIOOlO1I0l1 := USERANSWER (RSGET1 (SINFORMUSER ,
  162. O1OOlI1IIIOO + ORD ('A')- 1 ), AHELPCTX )=CMYES ;{$ENDIF}END ;PROCEDURE Oll1OIl0OO (CONST OI0lI1010ll1:PATHSTR);
  163. FAR;VAR OIl1IOO00lI:PATHSTR;OIl10I10l,OI110IOOO0l0:PDOSSTREAM;{$IFDEF Windows}O11l0IO0:ARRAY [ 0 .. 255 ]  OF CHAR;
  164. {$ENDIF}BEGIN {$IFDEF Windows}OIl10I10l := NEW (PBUFSTREAM , INIT (STRPCOPY (O11l0IO0 , OI0lI1010ll1 ), STOPEN +
  165. FMREADONLY + FMDENYWRITE , 8192 ));{$ELSE}OIl10I10l := NEW (PBUFSTREAM , INIT (OI0lI1010ll1 , STOPEN + FMREADONLY +
  166. FMDENYWRITE , 8192 ));{$ENDIF}IF OIl10I10l ^. STATUS <> STOK THEN BEGIN PRINTERROR ('Could not read '+ OI0lI1010ll1 +
  167. '.', AHELPCTX );EXIT ;END ;OIl1IOO00lI := MATCHFILENAMES (OI0lI1010ll1 , DESTINATION );{$IFDEF Windows}OI110IOOO0l0 :=
  168. NEW (PBUFSTREAM , INIT (STRPCOPY (O11l0IO0 , OIl1IOO00lI ), STCREATE + FMWRITEONLY + FMDENYALL , 8192 ));
  169. {$ELSE}OI110IOOO0l0 := NEW (PBUFSTREAM , INIT (OIl1IOO00lI , STCREATE + FMWRITEONLY + FMDENYALL , 8192 ));{$ENDIF}IF
  170. OI110IOOO0l0 ^. STATUS <> STOK THEN BEGIN PRINTERROR ('Could not create '+ OIl1IOO00lI + '.', AHELPCTX );EXIT ;END ;
  171. OI110IOOO0l0 ^. COPYFROM (OIl10I10l ^, OIl10I10l ^. GETSIZE );ASM {} LES DI , OIl10I10l{}
  172. MOV BX , ES : [ DI ] . TDOSSTREAM.HANDLE{} MOV AX , 5700h {} INT 21h {} LES DI , OI110IOOO0l0{}
  173. MOV BX , ES : [ DI ] . TDOSSTREAM.HANDLE{} MOV AX , 5701h {} INT 21h {} END;DISPOSE (OI110IOOO0l0 , DONE );DISPOSE
  174. (OIl10I10l , DONE );END ;BEGIN IF (DESTINATION [ LENGTH (DESTINATION )] <> '\')AND ISDIRECTORY (DESTINATION )THEN
  175. DESTINATION := DESTINATION + '\';FOREACHFILE (SOURCE , ARCHIVE , @ Oll1OIl0OO );END ;BEGIN IF MAXAVAIL < 3 * 8192 THEN
  176. BEGIN {$IFDEF Windows}PRINTERROR (RSGET (SNOTENOUGHMEMORY ), AHELPCTX );{$ELSE}IF BBSTRRES.STRINGS =NIL THEN PRINTERROR
  177. ('Not enough memory to copy files.', AHELPCTX )ELSE PRINTERROR (RSGET (SNOTENOUGHMEMORY ), AHELPCTX );{$ENDIF}DOSERROR :=
  178. 8 ;END ELSE O1lIOlO0O1l1 ;END ;PROCEDURE DOSMOVE (CONST SOURCE:PATHSTR;DEST:PATHSTR;AHELPCTX:WORD);PROCEDURE Ol1l0OOl1O
  179. (CONST Ol1O0OOI:PATHSTR);FAR;VAR OIl0:FILE ;O1lO0I00IOlO:PATHSTR;BEGIN O1lO0I00IOlO := MATCHFILENAMES (Ol1O0OOI , DEST );
  180. ASSIGN (OIl0 , O1lO0I00IOlO );DOSDEL (O1lO0I00IOlO );ASSIGN (OIl0 , Ol1O0OOI );RENAME (OIl0 , O1lO0I00IOlO );IOERROR
  181. (Ol1O0OOI , 0 );END ;VAR OI0lOOI1ll1O,O1OO1IIl010I:TDRIVESTR;O101IO1IOlIl1:SEARCHREC;BEGIN {$IFDEF Debug}ASSERT ((SOURCE
  182. <> '')AND (DEST <> ''), 'Source or destination empty');{$ENDIF}IF SOURCE =DEST THEN EXIT ;IF SOURCE [ 2 ] =':'THEN
  183. OI0lOOI1ll1O := UPSTR (COPY (SOURCE , 1 , 2 ))ELSE OI0lOOI1ll1O := GETDRIVE ;IF DEST [ 2 ] =':'THEN O1OO1IIl010I := UPSTR
  184. (COPY (DEST , 1 , 2 ))ELSE O1OO1IIl010I := GETDRIVE ;IF OI0lOOI1ll1O <> O1OO1IIl010I THEN BEGIN DOSCOPY (SOURCE , DEST ,
  185. AHELPCTX );DOSDEL (SOURCE );END ELSE BEGIN IF (DEST [ LENGTH (DEST )] <> '\')AND ISDIRECTORY (DEST )THEN DEST := DEST +
  186. '\';FOREACHFILE (SOURCE , ARCHIVE , @ Ol1l0OOl1O );END ;END ;PROCEDURE DOSWIPE (CONST PATH:PATHSTR);VAR OIl0:FILE ;
  187. O101IO1IOlIl1:SEARCHREC;PROCEDURE OlOII10100 (VAR OIl0:FILE );CONST O1lI00Oll1lO:BYTE=0 ;OI1II1OIOIOl:BYTE=$FF ;
  188. OI1IIO00I1ll:BYTE=$F6 ;VAR OIO11IOOlO0:WORD;OIlO:LONGINT;OIll:WORD;BEGIN RESET (OIl0 , 1 );FOR OIll := 1 TO 3
  189.  DO BEGIN SEEK (OIl0 , 0 );FOR OIlO := 0 TO FILESIZE (OIl0 )- 1  DO BLOCKWRITE (OIl0 , OI1II1OIOIOl , 1 , OIO11IOOlO0 );
  190. SEEK (OIl0 , 0 );FOR OIlO := 0 TO FILESIZE (OIl0 )- 1  DO BLOCKWRITE (OIl0 , O1lI00Oll1lO , 1 , OIO11IOOlO0 );END ;SEEK
  191. (OIl0 , 0 );FOR OIlO := 0 TO FILESIZE (OIl0 )- 1  DO BLOCKWRITE (OIl0 , OI1IIO00I1ll , 1 , OIO11IOOlO0 );CLOSE (OIl0 );
  192. END ;PROCEDURE OOlI1IlI0O0O ;BEGIN RESET (OIl0 );TRUNCATE (OIl0 );CLOSE (OIl0 );RENAME (OIl0 , 'TMP00000.$$$');END ;
  193. VAR {$IFDEF Windows}OIlIl0O00Il:ARRAY [ 0 .. FSPATHNAME]  OF CHAR;OOlOO1OIl000:ARRAY [ 0 .. FSDIRECTORY]  OF CHAR;
  194. OI111IlIO110:ARRAY [ 0 .. FSFILENAME]  OF CHAR;OO01IOOlI11:ARRAY [ 0 .. FSEXTENSION]  OF CHAR;{$ELSE}OIOO:DIRSTR;
  195. OO0O:NAMESTR;OIOl:EXTSTR;{$ENDIF}BEGIN {$IFDEF Windows}FILESPLIT (STRPCOPY (OIlIl0O00Il , PATH ), OOlOO1OIl000 ,
  196. OI111IlIO110 , OO01IOOlI11 );FINDFIRST (OIlIl0O00Il , FAARCHIVE , O101IO1IOlIl1 );{$ELSE}FSPLIT (PATH , OIOO , OO0O ,
  197. OIOl );FINDFIRST (PATH , ARCHIVE , O101IO1IOlIl1 );{$ENDIF}WHILE DOSERROR =0  DO BEGIN {$IFDEF Windows}ASSIGN (OIl0 ,
  198. STRPAS (OOlOO1OIl000 )+ O101IO1IOlIl1.NAME );{$ELSE}ASSIGN (OIl0 , OIOO + O101IO1IOlIl1.NAME );{$ENDIF}OlOII10100 (OIl0
  199. );OOlI1IlI0O0O ;ERASE (OIl0 );FINDNEXT (O101IO1IOlIl1 );END ;END ;PROCEDURE DOSTOUCH (CONST PATH:PATHSTR);
  200. PROCEDURE O1l0IOlIOOOO (CONST Ol1O0OOI:PATHSTR);FAR;VAR OIl0:FILE ;OI111O0100ll:LONGINT;OO1l:DATETIME;
  201. OOIl,OIO0OI11l1l,O101OO1O,OIlO11001ll:WORD;OIlI,OO0I,OO1O,O10lO0O0:WORD;BEGIN ASSIGN (OIl0 , Ol1O0OOI );RESET (OIl0 , 1
  202. );GETFTIME (OIl0 , OI111O0100ll );UNPACKTIME (OI111O0100ll , OO1l );GETDATE (OOIl , OIO0OI11l1l , O101OO1O , OIlO11001ll
  203. );GETTIME (OIlI , OO0I , OO1O , O10lO0O0 );WITH OO1l DO BEGIN YEAR := OOIl ;MONTH := OIO0OI11l1l ;DAY := O101OO1O ;HOUR
  204. := OIlI ;MIN := OO0I ;SEC := OO1O ;END ;PACKTIME (OO1l , OI111O0100ll );SETFTIME (OIl0 , OI111O0100ll );CLOSE (OIl0 );
  205. END ;BEGIN FOREACHFILE (PATH , ARCHIVE , @ O1l0IOlIOOOO );END ;PROCEDURE CREATEBAK (CONST FILENAME:PATHSTR;
  206. HELPCTX:WORD);BEGIN DOSMOVE (FILENAME , FFORCEEXTENSION (FILENAME , '.BAK'), HELPCTX );END ;FUNCTION FCREATE (VAR F:FILE
  207. ;AFILEMODE:WORD):INTEGER ;VAR OIO11IOOlO0:WORD;BEGIN IF AFILEMODE AND FMWRITEONLY <> 0 THEN BEGIN AFILEMODE := AFILEMODE
  208. AND NOT FMWRITEONLY ;AFILEMODE := AFILEMODE OR FMREADWRITE ;END ;REPEAT REWRITE (F , 1 );OIO11IOOlO0 := IORESULT ;IF
  209. OIO11IOOlO0 =0 THEN BEGIN CLOSE (F );OIO11IOOlO0 := FOPEN (F , AFILEMODE );END ;UNTIL (AFILEMODE AND FMNOWAIT =0 )OR
  210. (OIO11IOOlO0 =0 );FCREATE := OIO11IOOlO0 ;END ;FUNCTION FDEFAULTEXTENSION (CONST FILENAME:PATHSTR;
  211. CONST EXT:EXTSTR):STRING ;VAR OIOO:DIRSTR;OO0O:NAMESTR;OIOl:EXTSTR;BEGIN XFSPLIT (FILENAME , OIOO , OO0O , OIOl );IF OIOl
  212. =''THEN FDEFAULTEXTENSION := FILENAME + EXT ELSE FDEFAULTEXTENSION := FILENAME ;END ;{$IFDEF Windows}FUNCTION FEXPAND
  213. (PATH:PATHSTR):PATHSTR ;VAR OIlI1OlO00I,OI0lO01l1IlI:ARRAY [ 0 .. 127 ]  OF CHAR;BEGIN FILEEXPAND (OIlI1OlO00I , STRPCOPY
  214. (OI0lO01l1IlI , PATH ));FEXPAND := STRPAS (OIlI1OlO00I );END ;{$ENDIF}FUNCTION FFORCEEXTENSION (CONST FILENAME:PATHSTR;
  215. CONST EXT:EXTSTR):STRING ;VAR OIOO:DIRSTR;OO0O:NAMESTR;OIOl:EXTSTR;BEGIN XFSPLIT (FILENAME , OIOO , OO0O , OIOl );
  216. FFORCEEXTENSION := OIOO + OO0O + EXT ;END ;FUNCTION FFORCEDIR (CONST FILENAME:PATHSTR;DIR:DIRSTR):STRING ;
  217. VAR OIOO:DIRSTR;OO0O:NAMESTR;OIOl:EXTSTR;BEGIN XFSPLIT (FILENAME , OIOO , OO0O , OIOl );IF (DIR <> '')AND (DIR [ LENGTH
  218. (DIR )] <> '\')THEN DIR := DIR + '\';FFORCEDIR := DIR + OO0O + OIOl ;END ;FUNCTION FILEEXIST
  219. (CONST FILENAME:PATHSTR):BOOLEAN ;VAR OIl0:FILE ;Ol00IO0IOlO0:WORD;BEGIN ASSIGN (OIl0 , FILENAME );GETFATTR (OIl0 ,
  220. Ol00IO0IOlO0 );FILEEXIST := DOSERROR =0 ;END ;FUNCTION FILEOPEN (VAR F):BOOLEAN ;BEGIN FILEOPEN := (FILEREC (F ). MODE
  221. =FMINOUT )OR (FILEREC (F ). MODE =FMOUTPUT )OR (FILEREC (F ). MODE =FMINPUT );END ;FUNCTION FOPEN (VAR F:FILE ;
  222. AFILEMODE:WORD):INTEGER ;VAR O111O11I:BYTE;OIOO:WORD;BEGIN O111O11I := FILEMODE ;FILEMODE := AFILEMODE ;RESET (F , 1 );
  223. WHILE (AFILEMODE AND FMNOWAIT =0 )AND (INOUTRES <> 0 ) DO BEGIN CASE INOUTRES  OF 33 , 32 , 5 , 162 :DELAY (100 );ELSE
  224. BEGIN IF FILEOPEN (FERR )THEN WRITELN (FERR , 'FOpen IOError = ', INOUTRES );BREAK ;END ;END ;OIOO := IORESULT ;RESET (F
  225. , 1 );END ;FOPEN := IORESULT ;;FILEMODE := O111O11I ;END ;PROCEDURE FOREACHFILE (CONST PATH:PATHSTR;ATTR:WORD;
  226. ACTION:POINTER);VAR O101IO1IOlIl1:SEARCHREC;{$IFDEF Windows}OIlIl0O00Il:ARRAY [ 0 .. FSPATHNAME]  OF CHAR;
  227. {$ENDIF}OIOO:DIRSTR;OO0O:NAMESTR;OIOl:EXTSTR;OIOI0l0II11:PATHSTR;BEGIN XFSPLIT (PATH , OIOO , OO0O , OIOl );
  228. {$IFDEF Windows}FINDFIRST (STRPCOPY (OIlIl0O00Il , PATH ), ATTR , O101IO1IOlIl1 );{$ELSE}FINDFIRST (PATH , ATTR ,
  229. O101IO1IOlIl1 );{$ENDIF}WHILE DOSERROR =0  DO BEGIN {$IFDEF Windows}OIOI0l0II11 := OIOO + STRPAS (O101IO1IOlIl1.NAME );
  230. {$ELSE}OIOI0l0II11 := OIOO + O101IO1IOlIl1.NAME ;{$ENDIF}ASM {} MOV AX , SS {} LEA DI , OIOI0l0II11{} PUSH AX {}
  231. PUSH DI {} {$IFDEF Windows} {} MOV AX , [ BP ] {} AND AL , 0FEH {} PUSH AX {} {$ELSE} {} PUSH WORD PTR [ BP ] {}
  232. {$ENDIF} {} CALL ACTION{} END;FINDNEXT (O101IO1IOlIl1 );END ;END ;FUNCTION GETDRIVE :TDRIVESTR ;
  233. VAR O10O11I0I01O0:REGISTERS;OO1O:TDRIVESTR;BEGIN O10O11I0I01O0.AX := $1900 ;MSDOS (O10O11I0I01O0 );GETDRIVE := CHR (65 +
  234. O10O11I0I01O0.AL )+ ':';END ;FUNCTION GETFILENAME (VAR F:FILE ):STRING ;BEGIN GETFILENAME := COPY (FILEREC (F ). NAME , 1
  235. , POS (#0, FILEREC (F ). NAME )- 1 );END ;FUNCTION GETTEXTFILENAME (VAR T:TEXT):STRING ;BEGIN GETTEXTFILENAME := COPY
  236. (TEXTREC (T ). NAME , 1 , POS (#0, TEXTREC (T ). NAME )- 1 );END ;FUNCTION GETUNIQUEFILENAME (CONST DIR:PATHSTR):STRING ;
  237. VAR OO1O:PATHSTR;OIlO:INTEGER;BEGIN FILLCHAR (OO1O , SIZEOF (OO1O ), 0 );OO1O := DIR ;IF OO1O [ LENGTH (OO1O )] <>
  238. '\'THEN OO1O := OO1O + '\';ASM {} PUSH DS {} MOV CL , SYSTEM.FILEMODE{} XOR CH , CH {} MOV AX , SS {} MOV DS , AX {}
  239. LEA DX , OO1O[ 1 ] {} MOV AH , 05ah {} INT 021h {} MOV BX , AX {} MOV AH , 03eh {} INT 021h {} MOV AH , 041h {}
  240. INT 021h {} POP DS {} END;OIlO := LENGTH (OO1O )+ 2 ;WHILE OO1O [ OIlO ] <> #0 DO INC (OIlO );OO1O [ 0 ] := CHR (OIlO - 1
  241. );GETUNIQUEFILENAME := OO1O ;END ;FUNCTION ISDIRECTORY (DIR:DIRSTR):BOOLEAN ;VAR OI10O00llI:DIRSTR;
  242. BEGIN {$IFDEF Debug}ASSERT (DIR <> '', '');{$ENDIF}IF DIR [ LENGTH (DIR )] ='\'THEN DELETE (DIR , LENGTH (DIR ), 1 );
  243. GETDIR (0 , OI10O00llI );CHDIR (DIR );ISDIRECTORY := IORESULT =0 ;CHDIR (OI10O00llI );END ;FUNCTION IOERROR
  244. (CONST S:STRING ;AHELPCTX:WORD):BOOLEAN ;BEGIN IOERRNUM := IORESULT ;IF IOERRNUM <> 0 THEN BEGIN IOERROR := TRUE ;
  245. {$IFNDEF Windows}IF STRINGS =NIL THEN BEGIN CASE IOERRNUM  OF 2 , 3 :PRINTERROR ('File '+ S + ' not found.', AHELPCTX );
  246. 4 :PRINTERROR ('Too many open files.', AHELPCTX );5 :PRINTERROR ('File '+ S + ' is read-only.', AHELPCTX );100
  247. :PRINTERROR ('Disk read error.', AHELPCTX );101 :PRINTERROR ('Disk write error or disk full.', AHELPCTX );103 :PRINTERROR
  248. ('File '+ S + ' not open or disk not formatted.', AHELPCTX );150 :PRINTERROR ('Disk is write-protected.', AHELPCTX );152
  249. :PRINTERROR ('Drive not ready.', AHELPCTX );159 :PRINTERROR ('Printer out of paper', AHELPCTX );162 :PRINTERROR
  250. ('Hardware failure.', AHELPCTX );ELSE PRINTERROR ('Internal error. '+ S , AHELPCTX );END ;END ELSE
  251. BEGIN {$ENDIF}CASE IOERRNUM  OF 2 , 3 :PRINTERROR (RSGET2 (SFILENOTFOUND , IOERRNUM , LONGINT (@ S )), AHELPCTX );4
  252. :PRINTERROR (RSGET (STOOMANYOPENFILES ), AHELPCTX );5 :PRINTERROR (RSGET2 (SFILEREADONLY , IOERRNUM , LONGINT (@ S )),
  253. AHELPCTX );100 :PRINTERROR (RSGET (SDISKREADERROR ), AHELPCTX );101 :PRINTERROR (RSGET (SDISKFULL ), AHELPCTX );103
  254. :PRINTERROR (RSGET1 (SFILENOTOPEN , LONGINT (@ S )), AHELPCTX );150 :PRINTERROR (RSGET (SDISKWRITEPROTECTED ), AHELPCTX
  255. );152 :PRINTERROR (RSGET (SDRIVENOTREADY ), AHELPCTX );159 :PRINTERROR (RSGET (SOUTOFPAPER ), AHELPCTX );162 :PRINTERROR
  256. (RSGET (SHARDWAREFAILURE ), AHELPCTX );ELSE PRINTERROR (RSGET1 (SINTERNALERROR , IOERRNUM ), AHELPCTX );END ;
  257. {$IFNDEF Windows}END ;{$ENDIF}END ELSE IOERROR := FALSE ;END ;FUNCTION MATCHFILENAMES (CONST SOURCE,DEST:PATHSTR):STRING
  258. ;VAR OO10:WORD;OIlO:INTEGER;O1lIIlO1I0lI,OOO0OOI1ll10:DIRSTR;OII010l00O,O1lO0I00IOlO:NAMESTR;
  259. O1010O1I0I10O,OI1OO1IIOl:EXTSTR;BEGIN {$IFDEF Debug}ASSERT ((DEST [ LENGTH (DEST )] ='\')OR NOT ISDIRECTORY (DEST ),
  260. 'Destination should not be a directory');{$ENDIF}XFSPLIT (SOURCE , O1lIIlO1I0lI , OII010l00O , O1010O1I0I10O );XFSPLIT
  261. (DEST , OOO0OOI1ll10 , O1lO0I00IOlO , OI1OO1IIOl );IF O1lO0I00IOlO =''THEN BEGIN O1lO0I00IOlO := OII010l00O ;OI1OO1IIOl
  262. := O1010O1I0I10O ;END ELSE BEGIN OO10 := CPOS ('*', O1lO0I00IOlO );IF OO10 > 0 THEN BEGIN DELETE (O1lO0I00IOlO , OO10 ,
  263. LENGTH (O1lO0I00IOlO ));O1lO0I00IOlO := O1lO0I00IOlO + COPY (OII010l00O , OO10 , LENGTH (OII010l00O ));END ELSE
  264. BEGIN OO10 := CPOS ('?', O1lO0I00IOlO );IF OO10 > 0 THEN BEGIN FOR OIlO := OO10 TO LENGTH (O1lO0I00IOlO ) DO IF
  265. (O1lO0I00IOlO [ OIlO ] ='?')AND (OIlO <= LENGTH (OII010l00O ))THEN O1lO0I00IOlO [ OIlO ] := OII010l00O [ OIlO ] END ;
  266. END ;IF OI1OO1IIOl <> ''THEN BEGIN OO10 := CPOS ('*', OI1OO1IIOl );IF OO10 > 0 THEN BEGIN DELETE (OI1OO1IIOl , OO10 ,
  267. LENGTH (OI1OO1IIOl ));OI1OO1IIOl := OI1OO1IIOl + COPY (O1010O1I0I10O , OO10 , LENGTH (O1010O1I0I10O ));END ELSE
  268. BEGIN OO10 := CPOS ('?', OI1OO1IIOl );IF OO10 > 0 THEN BEGIN FOR OIlO := OO10 TO LENGTH (OI1OO1IIOl ) DO IF (OI1OO1IIOl [
  269. OIlO ] ='?')AND (OIlO <= LENGTH (O1010O1I0I10O ))THEN OI1OO1IIOl [ OIlO ] := O1010O1I0I10O [ OIlO ] END ;END ;END ;END ;
  270. MATCHFILENAMES := OOO0OOI1ll10 + O1lO0I00IOlO + OI1OO1IIOl ;END ;PROCEDURE SETHANDLECOUNT (HANDLES:WORD);BEGIN IF LO
  271. (DOSVERSION )>= 5 THEN BEGIN DOSERROR := 0 ;ASM {} MOV AH , 67h {} MOV BX , HANDLES{} INT 21h {} JNC @end {}
  272. MOV DOSERROR, AX {} @end : {} END;CASE DOSERROR  OF 0 :;8 :SETHANDLECOUNTDOS3 (HANDLES );ELSE PRINTERROR
  273. ('SetHandleCount failed. DosError = '+ STRW (DOSERROR ), 0 );END ;END ELSE IF LO (DOSVERSION )>= 3 THEN
  274. SETHANDLECOUNTDOS3 (HANDLES );END ;PROCEDURE SETHANDLECOUNTDOS3 (HANDLES:WORD);CONST O1lIlOIl1I0I=255 ;
  275. TYPE OOIl01IlO0Ol=^OOIl01IlO0O0;OOIl01IlO0O0=ARRAY [ 1 .. O1lIlOIl1I0I]  OF BYTE;VAR OOlIll0O0lll:OOIl01IlO0Ol;
  276. OIlO:INTEGER;OO01:LONGINT;BEGIN IF (LO (DOSVERSION )< 3 )OR (HANDLES > O1lIlOIl1I0I )THEN EXIT ;{$IFDef MsDos}GETMEM
  277. (OOlIll0O0lll , HANDLES );{$ELSE}OO01 := GLOBALDOSALLOC (HANDLES );OOlIll0O0lll := PTR (LONGREC (OO01 ). LO , 0 );
  278. {$ENDIF}FILLCHAR (OOlIll0O0lll ^, HANDLES , $FF );FOR OIlO := 1 TO MEMW [ PREFIXSEG :$32 ]  DO OOlIll0O0lll ^[ OIlO ] :=
  279. MEM [ PREFIXSEG :$18 + OIlO - 1 ] ;MEMW [ PREFIXSEG :$32 ] := HANDLES ;{$IFDEF MsDos}MEML [ PREFIXSEG :$34 ] := LONGINT
  280. (OOlIll0O0lll );{$ELSE}MEML [ PREFIXSEG :$34 ] := LONGINT (PTR (LONGREC (OO01 ). HI , 0 ));{$ENDIF}END ;
  281. PROCEDURE XFSPLIT (CONST PATH:PATHSTR;VAR DIR:DIRSTR;VAR NAME:NAMESTR;VAR EXT:EXTSTR);
  282. {$IFDEF Windows}VAR OIlIl0O00Il:ARRAY [ 0 .. FSPATHNAME]  OF CHAR;OIOO:ARRAY [ 0 .. FSDIRECTORY]  OF CHAR;OO0O:ARRAY [ 0
  283. .. FSFILENAME]  OF CHAR;OIOl:ARRAY [ 0 .. FSEXTENSION]  OF CHAR;{$ENDIF}BEGIN {$IFDEF Windows}STRPCOPY (OIlIl0O00Il ,
  284. PATH );FILESPLIT (OIlIl0O00Il , OIOO , OO0O , OIOl );DIR := STRPAS (OIOO );NAME := STRPAS (OO0O );EXT := STRPAS (OIOl );
  285. {$ELSE}FSPLIT (PATH , DIR , NAME , EXT );{$ENDIF}END ;FUNCTION XPARAMSTR (INDEX:WORD):STRING ;VAR OO1O:STRING ;BEGIN IF
  286. INDEX > PARAMCOUNT THEN XPARAMSTR := ''ELSE BEGIN OO1O := PARAMSTR (INDEX );IF LENGTH (OO1O )>= 1 THEN IF OO1O [ 1 ]
  287. ='/'THEN OO1O [ 1 ] := '-';IF OO1O ='-?'THEN OO1O := '-H';OO1O := UPSTR (OO1O );XPARAMSTR := OO1O ;END ;END ;END .
  288.