home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / turpas70.zip / GDOS.PAS < prev    next >
Pascal/Delphi Source File  |  2001-11-05  |  364KB  |  10,048 lines
  1.  
  2. {***************************************************************************}
  3. {                                                                           }
  4. {                         Turbo Pascal Version 7.0                          }
  5. {                           Graphic Vision Unit                             }
  6. {                                                                           }
  7. {                   Copyright (c) 1997-2001 Jason G Burgon                  }
  8. {                      http://www.jayman.demon.co.uk                        }
  9. {                      email: jay@jayman.demon.co.uk                        }
  10. {                                                                           }
  11. { Version: 2.20                                                             }
  12. { Date   : 3rd November 2001                                                }
  13. {                                                                           }
  14. { This unit is released as "freeware". No liability is accepted for its use.}
  15. { It is released merely in the hope that it may be of use others. YOU must  }
  16. { decide if this code is suitable for any purpose to which you put it.      }
  17. {                                                                           }
  18. { You can use the COMPILED code as part of any application you want, be it  }
  19. { commercial or free. You can distribute the source code, the intermediate  }
  20. { files GDOS.TPU and GDOS.TPP and its corresponding documentation ONLY if:  }
  21. {                                                                           }
  22. { (1) You did not obtain this software as part of the Graphic Vision(TM)    }
  23. {     software development package.                                         }
  24. {                                                                           }
  25. { (2) No part of the original distribution is changed in any way, including }
  26. {     this statement.                                                       }
  27. {                                                                           }
  28. { (3) You make no charge what so ever. No exceptions.                       }
  29. {                                                                           }
  30. { (4) You do not include GDOS or its documentation as a part of a larger    }
  31. {     programming library without the copyright holders express written     }
  32. {     permission.                                                           }
  33. {                                                                           }
  34. { All other rights not expressely given up in this statement are retained by}
  35. { the copyright holder.                                                     }
  36. {                                                                           }
  37. {---------------------------------------------------------------------------}
  38. {                                                                           }
  39. { The GDOS API is fully documented in the GDOS.TPH (or GVISION.TPH) IDE help}
  40. { file. Please add GDOS.TPH to your Borland/Turbo Pascal 7.0 IDE's help     }
  41. { files list (Help|Files - New) to obtain a detailed description of all     }
  42. { public functions, variables, types and symbolic constants declared by this}
  43. { unit. It also contains How-to's, O/S information and code examples.       }
  44. {                                                                           }
  45. { If you have found and fixed a bug, or have improved on the original code, }
  46. { please send me your modified source code, plus documented details of the  }
  47. { changes you have made, and I will consider them for inclusion in a later  }
  48. { version. Please check you have the most recent version before reporting a }
  49. { any bugs, and please keep to the coding style and naming convensions used }
  50. { thoughtout this unit. I will not look at anything that is too unlike it.  }
  51. {                                                                           }
  52. { This GDOS unit was originally written as part of my Graphic Vision(tm)    }
  53. { professional DOS/DPMI Graphical User Interface programming package.       }
  54. { Please visit my website to download Graphic Vision, GV example programs,  }
  55. { and to obtain the latest version of GDOS.                                 }
  56. {                                                                           }
  57. {---------------------------------------------------------------------------}
  58. {                                                                           }
  59. { Compilation Notes:                                                        }
  60. {                                                                           }
  61. { The Windows version of this unit is completely untested, so will almost   }
  62. { certainly not work properly when this unit is used as part of a native    }
  63. { Windows 3.x program. Quite a few GDOS functions should probably not be    }
  64. { part of the Windows version either. It needs someone with good knowledged }
  65. { of Win3x programming to get GDOS in shape for Win3.x native applications. }
  66. {                                                                           }
  67. { User Settable Conditional Defines:                                        }
  68. {                                                                           }
  69. { LongNames - Produces a unit that can handle Windows 9.x long filenames.   }
  70. {             A few of the structures, string types and constants are       }
  71. {             redefined in order to make this possible. All System unit     }
  72. {             functions dealing with file/directory names are "hooked" so   }
  73. {             that they too handle long filenames. LongNames is defined     }
  74. {             automatically only for the Windows verion of this unit.       }
  75. {                                                                           }
  76. { TurboDos  - Produces a smaller GDOS.TPP unit by using more assembler and  }
  77. {             calling those int $21 DOS functions that are known to be      }
  78. {             supported by the commonly used DPMI extenders.                }
  79. {                                                                           }
  80. { XMS30     - Uses XMS version 3.0 "super-extended" XMS functions for the   }
  81. {             (realmode-only) XMS extended memory interface. 3.0 functions  }
  82. {             make it possible to have access to all extendended memory, not}
  83. {             just the first 64MB.                                          }
  84. {                                                                           }
  85. { The defualt DPMI version of GDOS is compiled with TurboDos undefined. You }
  86. { can set it on or off for both the DOS and DPMI versions of this unit if   }
  87. { you wish. Defining TurboDos for DPMI means you're going to rely on a DOS  }
  88. { extender, making some functions smaller, but probably slower and less     }
  89. { robust. Clearing it for the DOS real mode version means larger, slower    }
  90. { code will be produced - more of it will be Pascal and not assembler.      }
  91. {                                                                           }
  92. { The default version of GDOS.TPU is compiled with XMS30 undefined. This    }
  93. { means that GDOS uses the XMS 2.0 API functions, so an XMS 3.0 compliant   }
  94. { driver is not required. This is because some versions of HIMEM.SYS (such  }
  95. { as that supplied with OpenDos 7.02) say they are 3.0 compliant when in    }
  96. { fact they are not - use HIMEM.SYS supplied  Windows 9x/ME instead.        }
  97. {                                                                           }
  98. {***************************************************************************}
  99.  
  100. unit GDos;
  101.  
  102. {$I-,S-,G+,X+,F-,O-}
  103.  
  104. {$C FIXED PRELOAD PERMANENT}
  105.  
  106. interface
  107.  
  108. {$ifdef MSDOS}
  109.    {$define TurboDos}        { Dos real mode apps don't use a DOS extender  }
  110.    {$define TurboLong}       { so Int 21 calls are used for everything, incl}
  111.    {.$define XMS30}          { Remove the '.' to use the XMS 3.0 API        }
  112. {$endif MSDOS}               { LFN functions when LongNames is defined.     }
  113.  
  114. {$ifdef DPMI}
  115.    {$ifdef LongNames}        { LFN functions are not supported by the Win9x }
  116.       {$undef TurboLong}     { or other DOS extenders, so LFN functions must}
  117.    {$endif LongNames}        { be called using DPMI server calls.           }
  118. {$endif DPMI}
  119.  
  120. {$ifdef Windows}
  121.     {$define TurboDos}       { Win3.x/9x servers are known to support the   }
  122.     {$define LongNames}      { int 21 functions used in this unit. Long     }
  123.     {$undef TurboLong}       { filename functions are not though.           }
  124. {$endif Windows}
  125.  
  126. { Simple types }
  127.  
  128. type
  129.   DWord   = Longint;
  130.   PDword  = ^DWord;
  131.  
  132.   QWord   = packed record
  133.               Lo: DWord;
  134.               Hi: DWord;
  135.             end;
  136.   PQWord  = ^QWord;
  137.  
  138. { Type conversion records }
  139.  
  140.   WordRec = packed record
  141.     Lo, Hi: Byte;
  142.   end;
  143.  
  144.   LongRec = packed record
  145.     Lo, Hi: Word;
  146.   end;
  147.  
  148.   PtrRec = packed record
  149.     Ofs, Seg: Word;
  150.   end;
  151.  
  152. { Simple pointer types }
  153.  
  154.   NearPtr   =  Word;
  155.   PByte     = ^Byte;
  156.   PShortInt = ^ShortInt;
  157.   PWord     = ^Word;
  158.   PInteger  = ^Integer;
  159.   PLongint  = ^Longint;
  160.   PString   = ^String;
  161.   PBoolean  = ^Boolean;
  162.   PWordBool = ^WordBool;
  163.  
  164. { Character set type }
  165.  
  166.   PCharSet = ^TCharSet;
  167.   TCharSet = set of Char;
  168.  
  169. { General arrays }
  170.  
  171.   PByteArray = ^TByteArray;
  172.   TByteArray = packed array[0..65534] of Byte;
  173.  
  174.   PWordArray = ^TWordArray;
  175.   TWordArray = packed array[0..32766] of Word;
  176.  
  177.   PIntArray  = ^TIntArray;
  178.   TIntArray  = packed array[0..32766] of Integer;
  179.  
  180.   PLongArray = ^TLongArray;
  181.   TLongArray = packed array[0..16382] of Longint;
  182.  
  183.   PCharArray = ^TCharArray;
  184.   TCharArray = packed array[0..65534] of Char;
  185.  
  186. const
  187.  
  188. { ASCII codes }
  189.  
  190.   asNull           = #0;
  191.   asBell           = #7;
  192.   asBackSpace      = #8;
  193.   asTab            = #9;
  194.   asLF             = #10;
  195.   asCR             = #13;
  196.   asEOF            = #26;
  197.   asEscape         = #27;
  198.   asSpace          = #32;
  199.   asDelete         = #127;
  200.  
  201. { Interrupt numbers }
  202.  
  203.   intDos           = $21;
  204.  
  205. {$ifdef DPMI}
  206.  
  207. { DPMI interrupt number }
  208.  
  209.   IntDPMI          = $31;
  210.  
  211. { DPMI function codes   }
  212.  
  213.   dpmiAllocSeg        = $0000;            { Allocate selector                  }
  214.   dpmiFreeSeg      = $0001;            { Free selector                      }
  215.   dpmiMapRealSeg   = $0002;            { Map real-mode segment to selector  }
  216.   dpmiAllocSegs    = $0003;            { Allocate multiple selectors        }
  217.   dpmiGetBaseAdr   = $0006;            { Get linear base address of segment }
  218.   dpmiSetSegBase   = $0007;            { Set selector base address          }
  219.   dpmiSetSegSize   = $0008;            { Set selector size                  }
  220.   dpmiSetAccess    = $0009;            { Set selector access rights & type  }
  221.   dpmiCloneSeg     = $000A;            { Create new selector with same props}
  222.   dpmiGetDesc      = $000B;            { Copy selectors LDT into 8-byte buf }
  223.   dpmiSetDesc      = $000C;            { Set selectors LDT from 8-byte buf  }
  224.  
  225.   dpmiGetRealInt   = $0200;            { Get real mode interrupt vector     }
  226.   dpmiSetRealInt   = $0201;            { Set real mode interrupt vector     }
  227.   dpmiGetExcpInt   = $0202;            { Get protected exception vector     }
  228.   dmpiSetExcpInt   = $0203;            { Set protected exception vector     }
  229.   dpmiGetProtInt   = $0204;            { Get protected mode interrupt vector}
  230.   dpmiSetProtInt   = $0205;            { Set protected mode interrupt vector}
  231.  
  232.   dpmiCallRealInt  = $0300;            { Call real-mode interrupt           }
  233.   dpmiCallRealFar  = $0301;            { Call far real-mode procedure       }
  234.   dpmiCalliret     = $0302;            { Call real-mode with IRET frame     }
  235.   dpmiAllocRMCB    = $0303;            { Allocate real mode call-back       }
  236.   dpmiFreeRMCB     = $0304;            { Free real mode call-back           }
  237.  
  238.   dpmiGetInfo      = $0400;            { Get DPMI server information        }
  239.  
  240.   dpmiDisableInt   = $0900;            { Get and disable virtual intr state }
  241.   dpmiEnableInt    = $0901;            { Get and enable virtual intr state  }
  242.   dpmiGetIntState  = $0902;            { Get virtual interrupt state        }
  243.  
  244. {$endif DPMI}
  245.  
  246. { Flags bit masks }
  247.  
  248.   fCarry           = $0001;
  249.   fParity          = $0004;
  250.   fAuxiliary       = $0010;
  251.   fZero            = $0040;
  252.   fSign            = $0080;
  253.   fOverflow        = $0800;
  254.  
  255. { File mode magic numbers }
  256.  
  257.   fmClosed         = $D7B0;
  258.   fmInput          = $D7B1;
  259.   fmOutput         = $D7B2;
  260.   fmInOut          = $D7B3;
  261.  
  262. { File attribute constants }
  263.  
  264.   faReadOnly       = $01;
  265.   faHidden         = $02;
  266.   faSysFile        = $04;
  267.   faVolumeID       = $08;
  268.   faDirectory      = $10;
  269.   faArchive        = $20;
  270.   faAnyFile        = faReadOnly + faHidden + faSysFile + faArchive;
  271.   faAnything       = faAnyFile + faDirectory;
  272.  
  273.   faReqReadOnly    = faReadOnly * 256;
  274.   faReqHidden      = faHidden   * 256;
  275.   faReqSysFile     = faSysFile  * 256;
  276.   faReqVolumeID    = faVolumeID * 256;
  277.   faReqDirectory   = faDirectory* 256;
  278.   faReqArchive     = faArchive  * 256;
  279.  
  280. { Volume attribute constants }
  281.  
  282.   vaCaseSensitive  = $0001;       { Directory searches are case sensitive   }
  283.   vaCasePreserve   = $0002;       { Preserves case in directory entries     }
  284.   vaUnicodeChars   = $0004;       { Unicode chars used in file & dir names  }
  285.  
  286.   vaIsNetWorkDrive = $0100;       { Volume is a network drive               }
  287.   vaIsRemoveable   = $0200;       { Drive media is removable                }
  288.   vaHasChangeLine  = $0400;       { Drive media supports ChangeLine mech    }
  289.   vaNoDiskInDrive  = $0800;       { No disk in drive - other flags unknown  }
  290.  
  291.   vaDosLongNames   = $4000;       { Volume supports Long filename functions }
  292.   vaCompressed     = $8000;       { Volume is a compressed drive            }
  293.  
  294. { File path component flags - passed to FExpand and returned by FileSplit}
  295.  
  296.   fcExtension      = $0001;
  297.   fcFileName       = $0002;
  298.   fcDirectory      = $0004;
  299.   fcWildcards      = $0008;
  300.   fcCasePreserve   = $0100;       { FExpand only - don't modify file case   }
  301.   fcNetPath        = $0200;       { FExpand only - don't convert net paths  }
  302.  
  303. { Date format constants }
  304.  
  305.   dfUsa            = 0;           { Month:Day:Year }
  306.   dfEurope         = 1;           { Day:Month:Year }
  307.   dfJapan          = 2;           { Year:Month:Day }
  308.  
  309. { Time format constants }
  310.  
  311.   tf12Hour         = 0;
  312.   tf24Hour         = 1;
  313.  
  314. { Currency format constants }
  315.  
  316.   cfPreFix         = $00;         { Currency symbol(s) preceed value:  $4.00}
  317.   cfPostFix        = $01;         { Currency symbol(s) follows value:  4.00$}
  318.   cfHasSpace       = $02;         { Put a space between             : $ 4.00}
  319.   cfDecPoint       = $04;         { Use symbol for decimal point    : 4$00  }
  320.  
  321. { Country codes }
  322.  
  323.   ccUnitedStates   = $001;
  324.   ccCanadianFrench = $002;
  325.   ccLatinAmerica   = $003;
  326.   ccNetherlands    = $01F;
  327.   ccBelgium        = $020;
  328.   ccFrance         = $021;
  329.   ccSpain          = $022;
  330.   ccHungary        = $024;        { not supported by DR DOS 5.0             }
  331.   ccYugoslavia     = $026;        { not supported by DR DOS 5.0             }
  332.   ccItaly          = $027;
  333.   ccSwitzerland    = $029;
  334.   ccCzechoslovakia = $02A;        { not supported by DR DOS 5.0             }
  335.   ccAustria        = $02B;        { DR DOS 5.0                              }
  336.   ccUnitedKingdom  = $02C;
  337.   ccDenmark        = $02D;
  338.   ccSweden         = $02E;
  339.   ccNorway         = $02F;
  340.   ccPoland         = $030;        { not supported by DR DOS 5.0             }
  341.   ccGermany        = $031;
  342.   ccBrazil         = $037;        { not supported by DR DOS 5.0             }
  343.   ccEnglish        = $03D;        { Australia in DR DOS 5.0                 }
  344.   ccJapan          = $051;        { DR DOS 5.0, MS-DOS 5.0+                 }
  345.   ccKorea          = $052;        { DR DOS 5.0                              }
  346.   ccChina          = $056;        { MS-DOS 5.0+                             }
  347.   ccTaiwan         = $058;        { MS-DOS 5.0+                             }
  348.   ccTurkey         = $05A;        { MS-DOS 5.0+                             }
  349.   ccPortugal       = $15F;
  350.   ccIceland        = $162;
  351.   ccFinland        = $166;
  352.   ccMiddleEast     = $311;       { Saudi Arabia DR DOS 5.0,MS-DOS 5.0+      }
  353.   ccIsrael         = $3CC;       { DR DOS 5.0,MS-DOS 5.0+                   }
  354.  
  355. { Block Device Type numbers  }
  356.  
  357. const
  358.   dtFloppy360  =  0; dtFloppy1200 =  1; dtFloppy720  =  2; dtBigFloppySD=  3;
  359.   dtBigFloppyDD=  4; dtFixedDisk  =  5; dtTapeDriv   =  6; dtFloppy1440 =  7;
  360.   dtFloppy2880 =  8; dtUnknown    =  9; dtNet1       = 10; dtNet2       = 11;
  361.   dtCdRom      = 12; dtRam        = 13; dtError      = 255;
  362.  
  363. type
  364.   TMediaLevel = (mcNo, mcUnknown, mcNotReady, mcYes); { Media changed states}
  365.  
  366. const
  367. { Dos Extended Errors }
  368.  
  369.   deUnknownErr     = -1;
  370.   deNoError        = 0;
  371.   deInvalidfunc    = 1;
  372.   deFileNotFound   = 2;
  373.   dePathNotFound   = 3;
  374.   deNoHandles      = 4;
  375.   deAccessDenied   = 5;
  376.   deInvalidHandle  = 6;
  377.   deCtrlBlkKilled  = 7;
  378.   deNotEnoughMem   = 8;
  379.   deBadMemBlock    = 9;
  380.   deBadEnvironment = 10;
  381.   deInvalidFormat  = 11;
  382.   deBadAccessCode  = 12;
  383.   deDataInvalid    = 13;
  384.   deInvalidDrive   = 15;
  385.   deDelCurrentDir  = 16;
  386.   deNotSameDevice  = 17;
  387.   deNoMoreFiles    = 18;
  388.   deWriteProtected = 19;
  389.   deUnknownUnit    = 20;
  390.   deDriveNotReady  = 21;
  391.   deUnknownCommand = 22;
  392.   deCRC            = 23;
  393.   deBadStrucLen    = 24;
  394.   deSeek           = 25;
  395.   deUnknownMedia   = 26;
  396.   deSectorNotFound = 27;
  397.   deNoPaper        = 28;
  398.   deWriteFault     = 29;
  399.   deReadFault      = 30;
  400.   deGeneralFailure = 31;
  401.   deShareViolation = 32;
  402.   deLockViolation  = 33;
  403.   deBadDiskChange  = 34;
  404.   deFCBUnavailable = 35;
  405.   deShareBuffer    = 36;
  406.   deCodePage       = 37;
  407.   deOutOfInput     = 38;
  408.   deNoDiskSpace    = 39;
  409.  
  410.   { 4x are extra error codes defined by the GDOS unit, not the O/S }
  411.  
  412.   deInvalidPath    = 40;      { Invalid character[s] in file/directory path }
  413.   deInvalidName    = 41;      { Invalid character[s] in FILENAME.EXT        }
  414.   deNameTooLong    = 42;      { FILENAME.EXT is too long                    }
  415.   deDirTooLong     = 43;      { Directory component of path is too long     }
  416.   dePathTooLong    = 43;      { Path (as a whole) is too long               }
  417.   deExtTooLong     = 44;      { Extension component of a path is too long   }
  418.   deNoWildCards    = 45;      { Path cannot contain wildcards               }
  419.  
  420.   deNetNoSupport   = 50;
  421.   deNetNoListen    = 51;
  422.   deNetDupName     = 52;
  423.   deNetNameNoFound = 53;
  424.   deNetBusy        = 54;
  425.   deNetNoExist     = 55;
  426.   deNetBiosCmdLim  = 56;
  427.   deNetAdaptHard   = 57;
  428.   deNetBadResponse = 58;
  429.   deNetUnexpected  = 59;
  430.   dePrintQueFull   = 60;
  431.   deQueNotFull     = 61;
  432.   deNoPrintSpace   = 62;
  433.   deNetNameDeleted = 64;
  434.   deNetNoAccess    = 65;
  435.   deNetDeviceType  = 66;
  436.   deNetNameNotFnd  = 67;
  437.   deNetNameTooLong = 68;
  438.   deNetBiosLimit   = 69;
  439.   deNetTempPause   = 70;
  440.   deNetBadRequest  = 71;
  441.   deNetPauseRedrct = 72;
  442.   deNetNoSoftware  = 73;
  443.   deNetBadAccount  = 74;
  444.   deNetBadPassword = 75;
  445.   deNetBadLogin    = 76;
  446.   deNetDiskLimit   = 77;
  447.   deNetNotLogged   = 78;
  448.   deFileExists     = 80;
  449.   deNoMakeDir      = 82;
  450.   deInt24Fail      = 83;
  451.   deRedirections   = 84;
  452.   deDupRedirect    = 85;
  453.   deBadPassword    = 86;
  454.   deBadParameter   = 87;
  455.   deNetWriteFault  = 88;
  456.   deNetBadFunction = 89;
  457.   deNoSystemComp   = 90;
  458.   deCdUnknown      = 100;
  459.   deCdNotReady     = 101;
  460.   deCdBadEMS       = 102;
  461.   deCdBadFormat    = 103;
  462.   deCdDoorOpen     = 104;
  463.  
  464. { Programmable Interrupt Timer types }
  465.  
  466.   pitEmulated  = 0;               { PIT is faulty or emulated by the O/S    }
  467.   pit8253      = 1;               { PIT is an 8253                          }
  468.   pit8254      = 2;               { PIT is an 8254                          }
  469.  
  470.   pitTimer0    = $40;             { 8254 Timer Chip port addresses          }
  471.   pitTimer1    = $41;
  472.   pitTimer2    = $42;
  473.   pitCtrl      = $43;
  474.  
  475. { FileOpen/TStream access modes }
  476.  
  477.   stCreate    = $3C00;            { Create new file       }
  478.   stOpenRead  = $3D00;            { Read access only      }
  479.   stOpenWrite = $3D01;            { Write access only     }
  480.   stOpen      = $3D02;            { Read and write access }
  481.  
  482. { File sharing constants: These can be added to the above access modes }
  483.  
  484.   stDenyAll   = $10;              { Deny any type of access to all others   }
  485.   stDenyWrite = $20;              { Deny write access by all others         }
  486.   stDenyNone  = $40;              { Allow read and write access by others   }
  487.   stDenyChild = $80;              { Deny access by child process            }
  488.  
  489. type
  490.  
  491. { File Seek modes }
  492.  
  493.   TFileSeek = (skStart,  { = $00 }{ Seek relative to start of file          }
  494.                skCurrent,{ = $01 }{ Seek relative to current file position  }
  495.                skEnd);   { = $02 }{ Seek relative to end of file            }
  496.  
  497.   DosPtr   = Pointer;    { Pointer to a DOS/BIOS (real mode) memory block   }
  498.   PDosPtr  = ^DosPtr;
  499.  
  500. { Filename case conversion }
  501.  
  502.   TFileCase = (fnPreserve, fnLowerCase, fnUpperCase, fnDosLower,
  503.                fnDos1stUpper);
  504.  
  505. { FileGetSetAttr operations }
  506.  
  507.   TAttrOp = (faGet, faSet);
  508.  
  509. type
  510.  
  511. { Block Device information record }
  512.  
  513.   PBlockDevInfo = ^TBlockDevInfo;
  514.   TBlockDevInfo = packed record
  515.     SpecialFunc: Byte;
  516.     DeviceType : Byte;         { See Block Device Type Numbers above        }
  517.     DeviceAttr : Word;         { See DeviceAttr bit-fields above            }
  518.     Cylinders  : Word;
  519.     MediaType  : Byte;
  520.  
  521.     BytesSect  : Word;         { Number of bytes per sector (eg 512)        }
  522.     SectClust  : Byte;         { Number of sectors per allocation unit      }
  523.     ResvSect   : Word;         { No. reserved sectors at start of the disk  }
  524.     NumFATs    : Byte;         { No. File Allocation Tables                 }
  525.     RootEntries: Word;         { Max No. of entries in the root directory   }
  526.     TotalSect  : Word;         { Total sectors or 0 if >32MB (see NumHuge)  }
  527.     MediaID    : Byte;
  528.     SectPerFAT : Word;         { Number of sectors per FAT                  }
  529.     SectTrack  : Word;         { Number of sectors per track                }
  530.     NumHeads   : Word;         { Number of drive heads                      }
  531.     NumHidden  : Longint;      { Number of hidden sectors                   }
  532.     NumHuge    : Longint;      { Actual Number of sectors if TotalSect = 0  }
  533.     Unused     : array[0..6] of byte;
  534.   end;
  535.  
  536. { GetDiskInfo record }
  537.  
  538.   PDiskInfo = ^TDiskInfo;
  539.   TDiskInfo = packed record
  540.     SectsPerCluster: Word;
  541.     BytesPerSector : Word;
  542.     ClustersFree   : DWord;
  543.     ClustersTotal  : DWord;
  544.   end;
  545.  
  546. { String types }
  547.  
  548.   TComStr      = String[127];          { Command line string                }
  549.   TVolLabel    = String[11];           { For holding a volume name          }
  550.   TRootStr     = String[2];            { For holding root dir name (eg "A:")}
  551.   TFileSysName = String[31];           { For file system name (eg 'FAT')    }
  552.   TNetName     = String[127];          { For local or network drive names.  }
  553.   TMachineName = String[15];           { For holding a LAN machine name     }
  554.   TDateStr     = String[10];           { For holding formated date string   }
  555.   TTimeStr     = String[13];           { For holding a formated time string }
  556.   TDosPath     = String[79];           { For holding a Dos 8.3 path         }
  557.   TDosName     = String[12];           { For holding a Dos 8.3 filename     }
  558.   TDosExt      = String[4];            { For holding a Dos .EXT component   }
  559. {$ifdef LongNames}
  560.   TPathStr     = String;               { LFN File pathname string           }
  561.   TDirStr      = String[246];          { LFN Drive and directory string     }
  562.   TNameStr     = String;               { LFN File name string               }
  563.   TExtStr      = String;               { LFN File extension string          }
  564.   TNameExt     = String;               { For holding a name + extension     }
  565.   TNetPath     = String;               { For network paths                  }
  566. {$else LongNames}
  567.   TPathStr     = String[79];           { DOS File pathname string           }
  568.   TDirStr      = String[67];           { DOS Drive and directory string     }
  569.   TNameStr     = String[8];            { DOS File name string               }
  570.   TExtStr      = String[4];            { DOS File extension string          }
  571.   TNameExt     = String[12];           { For holding a "filename.ext"       }
  572.   TNetPath     = String[127];          { For network paths/directories      }
  573. {$endif LongNames}
  574.  
  575.   PComStr      = ^TComStr;
  576.   PVolLabel    = ^TVolLabel;
  577.   PRootStr     = ^TRootStr;
  578.   PFileSysName = ^TFileSysName;
  579.   PNetName     = ^TNetName;
  580.   PDosPath     = ^TDosPath;
  581.   PDosName     = ^TDosName;
  582.   PDosExt      = ^TDosExt;
  583.   PMachineName = ^TMachineName;
  584.   PDateStr     = ^TDateStr;
  585.   PTimeStr     = ^TTimeStr;
  586.   PPathStr     = ^TPathStr;
  587.   PDirStr      = ^TDirStr;
  588.   PNameStr     = ^TNameStr;
  589.   PExtStr      = ^TExtStr;
  590.   PNameExt     = ^TNameExt;
  591.   PNetPath     = ^TNetPath;
  592.  
  593. { Maximum file name component string lengths }
  594.  
  595. const
  596. {$ifdef LongNames}
  597.   fsPathName   = 259;
  598.   fsNetPath    = fsPathName;
  599. {$else LongNames}
  600.   fsPathName   = High(TPathStr);
  601.   fsNetPath    = High(TNetPath);
  602. {$endif LongNames}
  603.   fsDirectory  = High(TDirStr);
  604.   fsExtension  = High(TExtStr);
  605.   fsFileName   = High(TNameStr);
  606.   fsNetName    = High(TNetName);
  607.   fsNameExt    = High(TNameExt);
  608.   fsDosPath    = High(TDosPath);
  609.   fsDosName    = High(TDosName);
  610.   fsDosExt     = High(TDosExt);
  611.   fsMachineName= High(TMachineName);
  612.   fsDosDir     = fsDosPath - fsDosName;
  613.   fsVolLabel   = High(TVolLabel);
  614.  
  615. type
  616.   PVolumeInfo = ^TVolumeInfo;
  617.   TVolumeInfo = packed record
  618.     VmtOffset  : NearPtr;              { For converting to an object        }
  619.     Next       : PVolumeInfo;          { Pointer to next TVolumeInfo in list}
  620.     Attributes : Word;                 { vaXXXX Volume attributes           }
  621.     MediaState : TMediaLevel;          { Last known state of the drive media}
  622.     Reserved   : Byte;                 { Reserved for future use            }
  623.     DriveType  : Byte;                 { dtXXXX Drive type                  }
  624.     DriveName  : TRootStr;             { Local drive name - eg 'A:'         }
  625.     NetName    : PNetName;             { Network drive name - eg '//machine'}
  626.     MaxNameLen : Word;                 { Maximum file/dir name.ext length   }
  627.     MaxExtLen  : Word;                 { Maximum file extension length      }
  628.     MaxPathLen : Word;                 { Maximum full path length           }
  629.     FileSysName: TFileSysName;         { File system used (FAT, CDFS, NTFS) }
  630.     VolumeLabel: TVolLabel;            { Volume label                       }
  631.     SerialNum  : DWord;                { Volume serial number               }
  632.   end;
  633.  
  634. { Create Volume information record }
  635.  
  636.   FCreateVolume = function(Drive: Char): PVolumeInfo;
  637.  
  638. { Registers record used by Intr, IntrPM, MsDos and MsDosPM }
  639.  
  640.   PRegisters = ^TRegisters;
  641.   TRegisters = packed record
  642.     case Integer of
  643.       0: (
  644.         EDI,ESI,EBP,EXX,EBX,EDX,ECX,EAX: DWord;
  645.         Flags,ES,DS,FS,GS,IP,CS,SP,SS: Word);
  646.       1: (
  647.         DI,DIH,SI,SIH,BP,BPH,XX,XXH: Word;
  648.         case Integer of
  649.           0: (
  650.             BX,BXH,DX,DXH,CX,CXH,AX,AXH: Word);
  651.           1: (
  652.             BL,BH,BLH,BHH,DL,DH,DLH,DHH,
  653.             CL,CH,CLH,CHH,AL,AH,ALH,AHH: Byte));
  654.   end;
  655.  
  656. { Structure used to allocate and access a DOS Memory block    }
  657.  
  658.   TDosBuf = packed record
  659.     {$ifdef DPMI}
  660.     case Integer of
  661.       0: (Buf    : Pointer;  { Application far pointer  }
  662.           RealBuf: DosPtr;   { Real mode far pointer    }
  663.           Size   : Word);    { Size of mem allocation   }
  664.       1: (Ofs    : Word;     { Protected offset (zero)  }
  665.           Seg    : Word;     { Protected selector       }
  666.           RealOfs: Word;     { Real mode offset (zero)  }
  667.           RealSeg: Word);    { Real mode segment        }
  668.     {$else DPMI}
  669.     case integer of
  670.       0: (Buf : Pointer;     { Application far pointer  }
  671.           Size: Word);       { Size of mem allocation   }
  672.       1: (RealBuf: DosPtr);  { Same as AppPtr in RM     }
  673.       2: (RealOfs: Word;     { Real mode offset (zero)  }
  674.           RealSeg: Word);    { Real mode segment        }
  675.       3: (Ofs: Word;         { Application offset (zero)}
  676.           Seg: Word);        { Application segment      }
  677.     {$endif DPMI}
  678.   end;
  679.  
  680. { DOS file handle type }
  681.  
  682.   TFileHandle = Word;
  683.  
  684. { XMS handle type      }
  685.  
  686. {$ifdef MsDos}
  687.   TXmsHandle = Word;
  688. {$endif MsDos}
  689.  
  690. { Redefined typed and untyped-file record }
  691.  
  692.   PFileRec = ^TFileRec;
  693.   TFileRec = packed record
  694.     Handle   : TFileHandle;            { O/S File handle                    }
  695.     Mode     : Word;                   { File access and sharing modes      }
  696.     RecSize  : Word;                   { Size of each file record in bytes  }
  697. {$ifdef LongNames}
  698.     NameLen  : Word;                   { No. characters in filename incl #0 }
  699.     Private  : array[1..24] of Byte;   { Not used - don't use it though     }
  700.     UserData : array[1..16] of Byte;   { 16 bytes available for any use     }
  701.     Name     : PChar;                  { Pointer to ASCIIZ filename         }
  702.     NameBuf  : array[1..80-SizeOf(PChar)] of Char; { For names of < 76 chars}
  703. {$else LongNames}
  704.     Private  : array[1..26] of Byte;   { Not used - don't use it though     }
  705.     UserData : array[1..16] of Byte;   { 16 bytes available for any use     }
  706.     Name     : array[0..79] of Char;   { ASCIIZ filename buffer             }
  707. {$endif LongNames}
  708.   end;
  709.  
  710.  { Redefined Textfile record - same as DOS.PAS declaration without LongNames}
  711.  
  712.   PTextBuf = ^TTextBuf;
  713.   TTextBuf = array[0..127] of Char;
  714.  
  715.   FOpenText  = function(var T: Text): Integer;
  716.   FCloseText = function(var T: Text): Integer;
  717.   FInOutText = function(var T: Text): Integer;
  718.   FFlushText = function(var T: Text): Integer;
  719.  
  720.   PTextRec = ^TTextRec;
  721.   TTextRec = record
  722.     Handle   : TFileHandle;            { O/S File handle                    }
  723.     Mode     : Word;                   { File access and sharing modes      }
  724.     BufSize  : Word;                   { Size of file buffr - 128 by default}
  725. {$ifdef LongNames}
  726.     NameLen  : Word;                   { No. characters in filename incl #0 }
  727. {$else LongNames}
  728.     Private  : Word;
  729. {$endif LongNames}
  730.     BufPos   : Word;                   { Current buffer position            }
  731.     BufEnd   : Word;                   { Pos of last valid byte in buf +1   }
  732.     BufPtr   : PTextBuf;               { Pointer to start of file buffer    }
  733.     OpenFunc : FOpenText;              { Pointer to "open file" function    }
  734.     InOutFunc: FInOutText;             { Pointer to "read/write" function   }
  735.     FlushFunc: FFlushText;             { Pointer to "flush file" function   }
  736.     CloseFunc: FCloseText;             { Pointer to "close file" function   }
  737.     UserData : array[1..16] of Byte;   { 16 bytes available for any use     }
  738. {$ifdef LongNames}
  739.     Name     : PChar;                  { Pointer to ASCIIZ filename         }
  740.     NameBuf  : array[1..80-SizeOf(PChar)] of Char; { For names of < 76 chars}
  741. {$else LongNames}
  742.     Name     : array[0..79] of Char;
  743. {$endif LongNames}
  744.     Buffer   : TTextBuf;
  745.   end;
  746.  
  747. { Search record used by FindFirst, FindNext and FindClose }
  748.  
  749.   PSearchRec = ^TSearchRec;
  750.   TSearchRec = packed record
  751.     Fill      : packed array[1..21] of Byte;
  752.     Attr      : Byte;
  753.     Time      : Longint;
  754.     Size      : Longint;
  755. {$ifdef Windows}
  756.     Name      : array[0..fsNameExt] of Char;
  757. {$else Windows}
  758.     Name      : TNameExt;
  759. {$endif Windows}
  760.     VolAttribs: Word;
  761.     Handle    : Word;
  762.     AttrMask  : Byte;
  763.     Reserved  : Byte;
  764.     UserData  : array[0..7] of Byte;
  765.   end;
  766.  
  767. { Date and time records used by PackTime and UnpackTime }
  768.  
  769.   PDateTime = ^TDateTime;
  770.   TDateTime = packed record
  771.     Year,Month,Day,Hour,Min,Sec: Word;
  772.   end;
  773.  
  774. { Country-specific information }
  775.  
  776.   PDosCountry = ^TDosCountry;
  777.   TDosCountry = packed record { 34 byte Country Dependant Information block }
  778.     DateFormat    : Word;                   { Date format - see dfXXXX      }
  779.     CurrencyStr   : String[4];              { Currency symbol(s). eg $      }
  780.     ThouSep       : array[0..1] of Char;    { Thousands separator: eg 1,000 }
  781.     DecSep        : array[0..1] of Char;    { Decimal point char: eg 1.23   }
  782.     DateSep       : array[0..1] of Char;    { Date separator: eg 01-01-80   }
  783.     TimeSep       : array[0..1] of Char;    { Time separator: eg 06:45:12   }
  784.     CurrencyFormat: Byte;                   { See cfXXXX constants          }
  785.     CurrencyDigits: Byte;                   { No. signif currency places    }
  786.     TimeFormat    : Byte;                   { 12/24 hour - see tfXXXX       }
  787.     UpCase        : DosPtr;                 { Dos UpCase function-don't call}
  788.     DataListSep   : array[0..1] of Char;
  789.     Reserved      : array[0..4] of Word;
  790.     CountryCode   : Word;                   { Country Code - see cnXXXX     }
  791.   end;
  792.  
  793. { Public constants }
  794.  
  795. const
  796.   maxFileBlock  = 65535;              { Max bytes in a single file transfer }
  797. {$ifdef DPMI}
  798.   maxDosMemBlock= 65535;
  799. {$else DPMI}
  800.   maxDosMemBlock= 65520;
  801. {$endif DPMI}
  802.   maxNullStrLen = maxDosMemBlock;
  803.  
  804. { Public variables }
  805.  
  806. var
  807.   StrError    : Integer;              { String error status                 }
  808.   DosError    : Word absolute InOutRes; { Error status variable             }
  809.   DosErrClass : Word;                 { Error class and suggested action    }
  810.   DosErrLocus : Byte;
  811.   DosVersion  : Word;                 { High byte = Major, Low byte = minor }
  812.   DosCountry  : TDosCountry;          { Country-specific information        }
  813.  
  814. const
  815. {$ifdef TurboDos}
  816.   DosBufSize  : Word = 1024;          { Default DosBuf mem allocation size  }
  817. {$else TurboDos}
  818.   DosBufSize  : Word = 4096;          { Used for file transfers too         }
  819. {$endif TurboDos}
  820.   DosBuf      : TDosBuf = (Buf: nil); { DOS memory buffer                   }
  821. const
  822.   MasterPicBase: Byte = $08;          { Primary PIC interrupt offset        }
  823.   SlavePicBase : Byte = $70;          { Secondary PIC interrupt offset      }
  824. const
  825.   VFat        : Boolean = false;      { Operating System supports LFN's     }
  826.   FileCase    : TFileCase = fnDos1stUpper;  { Filename case convertion rule }
  827. const
  828.   ExeDir      : TDirStr   = '';       { Drive & Directory path of the .EXE  }
  829.   ExeName     : TNameStr  = '';       { Filename without extension of .EXE  }
  830.   ExeExt      : TExtStr   = '';       { Extension of the .EXE, ie ".EXE"    }
  831. const
  832.   VolumeList  : PVolumeInfo = nil;    { Linked list of valid TVolumeInfo's  }
  833.   CreateVolume: FCreateVolume = nil;  { Create new volume info record/object}
  834. const
  835.   TempDir     : PDirStr   = nil;
  836.   TempPrefix  : String[5] = 'TEMP-';  { Temporary filename prefix           }
  837. {$ifdef MsDos}
  838. const                                 { Extra error codes for OvrResult     }
  839.   ovrNoXMSDriver      = -7;           { No XMS driver found                 }
  840.   ovrNoXMSMemory      = -8;           { XMS memory error, eg not enough     }
  841.  
  842. const
  843.   XmsInstalled: Boolean = false;      { If XMS present. Set by XMSInitHeap  }
  844.   XmsOverlays : Boolean = false;      { If overlays are being stored in XMS }
  845.   XmsVersion  : Word    = 0;          { 2-digit BCD Xms version number      }
  846.   XmsFunc     : Pointer = nil;        { The XMS driver's entry point        }
  847. {$endif MsDos}
  848.  
  849. (***************************************************************************
  850.   Case-conversion tables. NOTE : The second half, (from #128 to #255), of
  851.   both tables is overwritten during unit initialization due to the call to
  852.   InitCountry. This will use the MSDos case mapping function for characters
  853.   >= #128 to refill that portion of the array.
  854. ****************************************************************************)
  855.  
  856. const
  857.   LoToUpTbl: array[#0..#255] of Char =
  858.     (#00,#01,#02,#03,#04,#05,#06,#07,#08,#09,#10,#11,#12,#13,#14,#15,
  859.      #16,#17,#18,#19,#20,#21,#22,#23,#24,#25,#26,#27,#28,#29,#30,#31,
  860.      ' ','!','"','#','$','%','&',#39,'(',')','*','+',',','-','.','/',
  861.      '0','1','2','3','4','5','6','7','8','9',':',';','<','=','>','?',
  862.      '@','A','B','C','D','E','F','G','H','I','J','K','L','M','N','O',
  863.      'P','Q','R','S','T','U','V','W','X','Y','Z','[','\',']','^','_',
  864.      '`','A','B','C','D','E','F','G','H','I','J','K','L','M','N','O',
  865.      'P','Q','R','S','T','U','V','W','X','Y','Z','{','|','}','~',#127,
  866.      'Ç','Ü','É','A','Ä','A','Å','Ç','E','E','E','I','I','I','Ä','Å',
  867.      'É','Æ','Æ','O','Ö','O','U','U','Y','Ö','Ü','¢','£','¥','₧','ƒ',
  868.      'A','I','O','U','Ñ','Ñ','ª','º','¿','⌐','¬','½','¼','¡','«','»',
  869.      '░','▒','▓','│','┤','╡','╢','╖','╕','╣','║','╗','╝','╜','╛','┐',
  870.      '└','┴','┬','├','─','┼','╞','╟','╚','╔','╩','╦','╠','═','╬','╧',
  871.      '╨','╤','╥','╙','╘','╒','╓','╫','╪','┘','┌','█','▄','▌','▐','▀',
  872.      'α','ß','Γ','π','Σ','σ','µ','τ','Φ','Θ','Ω','δ','∞','φ','ε','∩',
  873.      '≡','±','≥','≤','⌠','⌡','÷','≈','°','∙','·','√','ⁿ','²','■',#255);
  874.  
  875.   UpToLoTbl: array[#0..#255] of Char =
  876.     (#00,#01,#02,#03,#04,#05,#06,#07,#08,#09,#10,#11,#12,#13,#14,#15,
  877.      #16,#17,#18,#19,#20,#21,#22,#23,#24,#25,#26,#27,#28,#29,#30,#31,
  878.      ' ','!','"','#','$','%','&',#39,'(',')','*','+',',','-','.','/',
  879.      '0','1','2','3','4','5','6','7','8','9',':',';','<','=','>','?',
  880.      '@','a','b','c','d','e','f','g','h','i','j','k','l','m','n','o',
  881.      'p','q','r','s','t','u','v','w','x','y','z','[','\',']','^','_',
  882.      '`','a','b','c','d','e','f','g','h','i','j','k','l','m','n','o',
  883.      'p','q','r','s','t','u','v','w','x','y','z','{','|','}','~',#127,
  884.      'ç','ü','é','â','ä','à','å','ç','ê','ë','è','ï','î','ì','ä','å',
  885.      'é','æ','æ','ô','ö','ò','û','ù','ÿ','ö','ü','¢','£','¥','₧','ƒ',
  886.      'á','í','ó','ú','ñ','ñ','ª','º','¿','⌐','¬','½','¼','¡','«','»',
  887.      '░','▒','▓','│','┤','╡','╢','╖','╕','╣','║','╗','╝','╜','╛','┐',
  888.      '└','┴','┬','├','─','┼','╞','╟','╚','╔','╩','╦','╠','═','╬','╧',
  889.      '╨','╤','╥','╙','╘','╒','╓','╫','╪','┘','┌','█','▄','▌','▐','▀',
  890.      'α','ß','Γ','π','Σ','σ','µ','τ','Φ','Θ','Ω','δ','∞','φ','ε','∩',
  891.      '≡','±','≥','≤','⌠','⌡','÷','≈','°','∙','·','√','ⁿ','²','■',#255);
  892.  
  893.  
  894. {*************************** Unit initialization ***************************}
  895.  
  896.  
  897. { Allocate DosBufSize bytes to the DosBuf App <-> O/S data buffer.          }
  898.  
  899. function  DosInit: Boolean;
  900.  
  901. { DeAllocate the memory assigned to the DosBuf App <-> O/S data buffer.     }
  902.  
  903. procedure DosDone;
  904.  
  905. {***************** Application <-> Operating system interface **************}
  906.  
  907.  
  908. { GetDosMem should be used to allocate a memory block suitable for passing  }
  909. { to a DOS or BIOS interrupt. Using MemAlloc guarantees that the memory     }
  910. { block has been allocated from the 1st MB of memory.                       }
  911.  
  912. function GetDosMem(var Buf: TDosBuf; Size: Word): Boolean;
  913.  
  914. { FreeDosMem disposes of a DOS buffer previously allocated with GetDosMem.  }
  915.  
  916. procedure FreeDosMem(var Buf: TDosBuf);
  917.  
  918. { Create an application pointer that points to the given DOS/BIOS memory    }
  919.  
  920. function MapDosPtr(RealPtr: DosPtr): Pointer;
  921.  {$ifdef MSDOS}
  922.    inline ($58/$5A);    { pop ax dx }
  923.  {$endif MSDOS}
  924.  
  925. { Free a pointer previously allocated by MapDosPtr }
  926.  
  927. procedure FreeDosPtr(P: Pointer); inline (
  928. {$ifdef DPMI}
  929.   $5A/$5B/          { pop dx bx          }
  930.   $B8/>$0001/       { mov ax,dpmiFreeSeg }
  931.   $CD/$31);         { int intDPMI        }
  932. {$else}
  933.   $5A/$59);         { pop dx cx          }
  934. {$endif DPMI}
  935.  
  936. { Intr executes a specified software interrupt with a specified TRegisters  }
  937. { package. Returns the value of Regs.AX (as set by the real mode interrupt).}
  938. { Intr always call the real-mode (O/S) version of the interrupt.            }
  939.  
  940. function Intr(IntNo: Byte; var Regs: TRegisters): Word;
  941. {$ifdef DPMI} inline (
  942.   $5F/              { pop di                                                }
  943.   $07/              { pop es                ES:DI = @Regs                   }
  944.   $B8/>$0300/       { mov ax,dpmiCallRealInt  Simulate real-mode interrupt  }
  945.   $5B/              { pop bx                BL = IntNo                      }
  946.   $31/$C9/          { xor cx,cx             No stack transfer               }
  947.   $B7/$00/          { mov bh,0              BH must be zero                 }
  948.   $CD/$31/          { int intDPMI                                           }
  949.   $26/$8B/$45/$1C); { mov ax,[es:di+TRegisters.AX]                          }
  950. {$endif DPMI}
  951.  
  952. { IntrApp calls protected-mode interrupt "IntNo". This differs from Intr    }
  953. { in protected mode because Intr will call the real-mode version of the     }
  954. { given interrupt number. IntrApp is the same as Intr for real-mode programs}
  955.  
  956. function IntrApp(IntNo: Byte; var Regs: TRegisters): Word;
  957.  
  958. { MsDos invokes the DOS function call handler with a specified Registers    }
  959. { package. Returns the value of Regs.AX (as set by the real mode interrupt).}
  960. { MsDos always calls the real mode version of interrupt $21.                }
  961.  
  962. function MsDos(var Regs: TRegisters): Word;
  963. {$ifdef DPMI} inline (
  964.   $BB/>$0021/       { mov bx,21h            Dos interrupt 21h (BH must be 0)}
  965.   $5F/              { pop di                                                }
  966.   $31/$C9/          { xor cx,cx             No stack transfer               }
  967.   $07/              { pop es                ES:DI = @Regs                   }
  968.   $B8/>$0300/       { mov ax,dpmiCallRealInt  Call real-mode interrupt in BL}
  969.   $CD/$31/          { int intDPMI                                           }
  970.   $26/$8B/$45/$1C); { mov ax,[es:di+TRegisters.AX]                          }
  971.  
  972. { MsDosPM is only avaiable in protected mode. It invokes the DPMI server's  }
  973. { Int $21 DOS function dispatch emulator. This should only be called while  }
  974. { converting existing applications.                                         }
  975.  
  976.   function MsDosPM(var Regs: TRegisters): Word;
  977. {$endif DPMI}
  978.  
  979. { Call a real mode function with far call (16:16) return stack frame. The   }
  980. { real mode address of the function to be called must be in Regs.CS and     }
  981. { Regs.IP. Returns the value of Regs.AX (as set by the real mode function). }
  982.  
  983. function DosFarCall(var Regs: TRegisters): Word;
  984. {$ifdef DPMI} inline (
  985.   $31/$DB/          { xor bx,bx         BH must be zero              }
  986.   $5F/              { pop di                                         }
  987.   $B8/>$0301/       { mov ax,dpmiCallRealFar                         }
  988.   $07/              { pop es            ES:DI = @Regs                }
  989.   $31/$C9/          { xor cx,cx         No stack transfer            }
  990.   $CD/$31/          { int intDPMI       Call real mode far procedure }
  991.   $26/$8B/$45/$1C); { mov ax,[es:di+TRegisters.AX]                   }
  992. {$endif DPMI}
  993.  
  994. { Call a real mode function with an IRET return stack frame. The real mode  }
  995. { address of the function to be called must be in Regs.CS and Regs.IP.      }
  996. { Returns the value of Regs.AX (as set by the real mode function). This is  }
  997. { used to chain an original DOS/BIOS software interrupt (eg Video BIOS      }
  998. { interrupt $10) from inside a user-installed interrupt service routine.    }
  999.  
  1000. function DosSoftIntr(var Regs: TRegisters): Word;
  1001. {$ifdef DPMI} inline (
  1002.   $31/$DB/          { xor bx,bx             BH must be zero                 }
  1003.   $5F/              { pop di                                                }
  1004.   $B8/>$0302/       { mov ax,dpmiCalliret                                   }
  1005.   $07/              { pop es                ES:DI = @Regs                   }
  1006.   $31/$C9/          { xor cx,cx             No stack transfer               }
  1007.   $CD/$31/          { int intDPMI           Call real-mode IRET procedure   }
  1008.   $26/$8B/$45/$1C); { mov ax,[es:di+TRegisters.AX]                          }
  1009. {$endif DPMI}
  1010.  
  1011. { Call a DOS/BIOS real mode function with an IRET return stack frame. This  }
  1012. { is used to call hardware interrupts (eg system clock interrupt $08) from  }
  1013. { inside a user-installed hardware interrupt service routine.               }
  1014.  
  1015. procedure DosHardIntr(RealAddr: DosPtr); inline (
  1016. {$ifdef DPMI}
  1017.   $58/          { pop   ax                   Pop interrupt addr into DX:AX  }
  1018.   $5A/          { pop   dx                                                  }
  1019.   $55/          { push  bp                   Save stack frame pointer       }
  1020.   $83/$EC/$32/  { sub   sp,type TRegisters   Make space on stack for Regs   }
  1021.   $31/$DB/      { xor   bx,bx                BH must be zero for Int 31h    }
  1022.   $89/$E5/      { mov   bp,sp                                               }
  1023.   $89/$5E/$26/  { mov   [bp+TRegisters.&FS],bx    Set Regs.FS & GS to zero. }
  1024.   $8C/$D1/      { mov   cx,ss                     Set ES:DI to index pseudo }
  1025.   $89/$5E/$28/  { mov   [bp+TRegisters.&GS],bx    Regs on the stack (@SS:BP)}
  1026.   $89/$EF/      { mov   di,bp                Set Regs.CS:IP to IntrAdr      }
  1027.   $89/$46/$2A/  { mov   [bp+TRegisters.&IP],ax                              }
  1028.   $8E/$C1/      { mov   es,cx                                               }
  1029.   $89/$56/$2C/  { mov   [bp+TRegisters.&CS],dx                              }
  1030.   $B8/$02/$03/  { mov   ax,dpmiCalliret      Call real-mode IRET procedure  }
  1031.   $31/$C9/      { xor   cx,cx                No stack transfer              }
  1032.   $CD/$31/      { int   intDPMI              Call the interrupt function    }
  1033.   $83/$C4/$32/  { add   sp,type TRegisters   Restore stack and stack frame  }
  1034.   $5D);         { pop   bp                   pointer                        }
  1035. {$else DPMI}
  1036.   $55/          { push  bp                   Save stack frame pointer       }
  1037.   $89/$E5/      { mov   bp,sp                Set bp to @RealAddr            }
  1038.   $9C/          { pushf                      Push Flags for the IRET return }
  1039.   $FF/$5E/$02/  { call  far ptr [bp+2]       Call the interrupt function    }
  1040.   $5D/          { pop   bp                   Restore stack frame pointer    }
  1041.   $83/$C4/$04); { add   sp,(type Pointer)    Pop the call address off stack }
  1042. {$endif DPMI}
  1043.  
  1044. { Call an application side function with an IRET return stack frame. This   }
  1045. { is used to call software interrupts (eg video interrupt $10) from inside  }
  1046. { the user-installed software interrupt service routine that replaced it.   }
  1047.  
  1048. function SoftIntr(var Regs: TRegisters): Word;
  1049.  
  1050. { Call an application side function with an IRET return stack frame. This   }
  1051. { is used to call hardware interrupts (eg clock interrupt $08) from inside  }
  1052. { the user-installed hardware interrupt service routine that replaced it.   }
  1053.  
  1054. procedure HardIntr(ISR: Pointer); inline (
  1055.   $55/          { push  bp                   Save stack frame pointer       }
  1056.   $89/$E5/      { mov   bp,sp                Set bp to @ISR                 }
  1057.   $9C/          { pushf                      Push Flags for the IRET return }
  1058.   $FF/$5E/$02/  { call  far ptr [bp+2]       Call the interrupt function    }
  1059.   $5D/          { pop   bp                   Restore stack frame pointer    }
  1060.   $83/$C4/$04); { add   sp,(type Pointer)    Pop the call address off stack }
  1061.  
  1062. { ClearRegs sets all register values to 0. This should be called before you }
  1063. { set specific Regs fields prior a call to Intr, IntrApp, MsDos, MsDosPM etc}
  1064.  
  1065. procedure ClearRegs(var Regs: TRegisters); inline (
  1066.   $5F/$07/  { pop di es  }
  1067.   $FC/      { cld        }
  1068.   $31/$C0/  { xor  ax,ax }
  1069.   $B9/>$19/ { mov  cx,type TRegisters/2 }
  1070.   $F3/$AB); { rep  stosw }
  1071.  
  1072. { PushAllRegs pushes DS, ES, EAX, ECX, EDX, EBX, ESP, EBP, ESI, EDI }
  1073.  
  1074. procedure PushAllRegs; inline (
  1075.   $1E/$06/  { push ds es }
  1076.   $66/$60); { pushad     }
  1077.  
  1078. { PopAllRegs pops EDI, ESI, EBP, EBX, EDX, ECX, EAX, ES, DS }
  1079.  
  1080. procedure PopAllRegs; inline (
  1081.   $66/$61/  { popad      }
  1082.   $07/$1F); { pop  es ds }
  1083.  
  1084. { GetIntVec returns the address of the given application mode interrupt.    }
  1085. { This function returns the protected-mode interrupt vector in DMPI.        }
  1086.  
  1087. function GetIntVec(IntNo: Byte): Pointer; inline (
  1088. {$ifdef DPMI}
  1089.   $B8/>$0204/      { mov ax,dpmiGetProtInt    Use DPMI sever to return the  }
  1090.   $5B/             { pop bx             address of the protected mode int   }
  1091.   $CD/$31/         { int intDPMI                                            }
  1092.   $89/$D0/         { mov ax,dx                                              }
  1093.   $89/$CA);        { mov dx,cx                                              }
  1094. {$else DPMI}
  1095.   $58/             { pop al [IntNo]     Use DOS to return the real mode     }
  1096.   $B4/$35/         { mov ah,35h         address of a real mode interrupt    }
  1097.   $CD/$21/         { int 21h            vector.                             }
  1098.   $8C/$C2/         { mov dx,es                                              }
  1099.   $89/$D8);        { mov ax,bx                                              }
  1100. {$endif DPMI}
  1101.  
  1102. { GetDosIntVec returns a real-mode (DOS/BIOS) vector. This function is the  }
  1103. { same as GetIntVec in DOS real mode programs.                              }
  1104.  
  1105. function GetDosIntVec(IntNo: Byte): DosPtr; inline (
  1106. {$ifdef DPMI}
  1107.   $B8/>$0200/      { mov ax,dpmiGetRealInt Use the DPMI sever to return the }
  1108.   $5B/             { pop bx [IntNo]        real mode address of a real mode }
  1109.   $CD/$31/         { int intDPMI           interupt vector.                 }
  1110.   $89/$D0/         { mov ax,dx                                              }
  1111.   $89/$CA);        { mov dx,cx                                              }
  1112. {$else DPMI}
  1113.   $58/             { pop al                Use DOS to return the real mode  }
  1114.   $B4/$35/         { mov ah,35h            address of a real mode interrupt }
  1115.   $CD/$21/         { int 21h               vector.                          }
  1116.   $8C/$C2/         { mov dx,es                                              }
  1117.   $89/$D8);        { mov ax,bx                                              }
  1118. {$endif DPMI}
  1119.  
  1120. { SetIntVec sets the address in the RM or PM interrupt vector table to the  }
  1121. { the specified application Vector. Sets PM interrupt vector in DPMI apps.  }
  1122.  
  1123. function SetIntVec(IntNo: Byte; Vector: Pointer): Boolean; inline (
  1124. {$ifdef DPMI}
  1125.   $5A/             { pop dx [word Vector]                                   }
  1126.   $B8/>$0205/      { mov ax,dpmiSetProtInt    Use the DPMI server to set a  }
  1127.   $59/             { pop cx [word Vector+2]   protected mode intrpt vector  }
  1128.   $5B/             { pop bx [IntNo]           to a protected mode address.  }
  1129.   $CD/$31);        { int intDPMI                                            }
  1130. {$else DPMI}
  1131.   $5A/             { pop  dx                  pop Vector into DX:CX         }
  1132.   $59/             { pop  cx                                                }
  1133.   $58/             { pop  ax                  AL = IntNo                    }
  1134.   $1E/             { push ds                  Save global DS                }
  1135.   $8E/$D9/         { mov  ds,cx               DS:DX = Vector                }
  1136.   $B4/$25/         { mov  ah,25h              Use DOS to set a real mode    }
  1137.   $CD/$21/         { int  21h                 interrupt vector to a real    }
  1138.   $1F);            { pop  ds                  mode address.                 }
  1139. {$endif DPMI}
  1140.  
  1141. { SetDosIntVec sets the given real-mode (DOS/BIOS) mode vector to the given }
  1142. { real-mode mode address. Same as SetIntVec in real-mode programs.          }
  1143.  
  1144. function SetDosIntVec(IntNo: Byte; Vector: DosPtr): Boolean; inline (
  1145. {$ifdef DPMI}
  1146.   $5A/             { pop  dx [word Vector]    Use the DPMI server to set a  }
  1147.   $B8/>$0201/      { mov  ax,dpmiSetRealInt   real mode interrupt vector to }
  1148.   $59/             { pop  cx [word Vector+2]  a real mode address.          }
  1149.   $5B/             { pop  bx [IntNo]          BL = IntNo   CX:DX = Vector   }
  1150.   $CD/$31);        { int  intDPMI                                           }
  1151. {$else DPMI}
  1152.   $5A/             { pop  dx                  Pop Vector into DX:CX         }
  1153.   $59/             { pop  cx                                                }
  1154.   $58/             { pop  ax                  AL = IntNo                    }
  1155.   $1E/             { push ds                  Save global DS                }
  1156.   $8E/$D9/         { mov  ds,cx               DS:DX = Vector                }
  1157.   $B4/$25/         { mov  ah,25h              Use DOS to set a real mode    }
  1158.   $CD/$21/         { int  21h                 interrupt vector to a real    }
  1159.   $1F);            { pop  ds                  mode address.                 }
  1160. {$endif DPMI}
  1161.  
  1162. { Replace a standard DOS/BIOS interrupt vector with a user-installed        }
  1163. { interrupt service routine. Returns true if the function was successful.   }
  1164.  
  1165. function HookDosIntr(IntNum: Byte; ISR: Pointer): Boolean;
  1166.  
  1167. { Unhook a DOS/BIOS interrupt vector previously hooked by the application.  }
  1168.  
  1169. function UnHookDosIntr(IntNum: Byte): Boolean;
  1170.  
  1171. { Replace an application-side interrupt service routine. Returns True if    }
  1172. { the function was successful.                                              }
  1173.  
  1174. function HookIntr(IntNum: Byte; ISR: Pointer): Boolean;
  1175.  
  1176. { Unhook a previously hooked application interrupt. }
  1177.  
  1178. function UnHookIntr(IntNum: Byte): Boolean;
  1179.  
  1180. { Allocate a real mode callback. CallBackProc is the procedure to be called,}
  1181. { HookProc must point to its install procedure, UnHookProc to its uninstall }
  1182. { procedure. ID is set on return and is passed to DoneCallBack to indentify }
  1183. { which callback to uninstall.                                              }
  1184.  
  1185. function InitCallBack(CallBackProc, HookProc, UnHookProc: Pointer;
  1186.                       var ID: Word): Boolean;
  1187.  
  1188. { Deallocate a real mode callback. ID is the callback idenfier (as returned }
  1189. { by the corresponing call to InitCallBack) you wish to uninstall           }
  1190.  
  1191. function DoneCallBack(ID: Word): Boolean;
  1192.  
  1193. { Unhook all interrupts and callbacks installed by HookIntr, HookDosIntr &  }
  1194. { InitCallBack. Called automatically by the program's termination code.     }
  1195.  
  1196. procedure UnHookAll;
  1197.  
  1198. { Enable hardware interrupts }
  1199.  
  1200. procedure EnableInterrupts; inline (
  1201.  $FB);    { sti }
  1202.  
  1203. { Disable hardware interrupts }
  1204.  
  1205. procedure DisableInterrupts; inline (
  1206.  $FA);    { cli }
  1207.  
  1208. { Interrupt Service Routine entry code. a "call" to this procedure MUST be  }
  1209. { the first statement of any Pascal based application-side ISR you define   }
  1210. { and install with the HookISR function.                                    }
  1211.  
  1212. procedure EnterISR; inline (                { Same as real-mode EnterDosISR }
  1213.  $29/$E5/             { sub   bp,sp    ; BP = SizeOf(Locals)                }
  1214.  $01/$EC/             { add   sp,bp    ; "Pop" Locals off the stack         }
  1215.  
  1216.  {             Flags  }
  1217.  {             CS     }
  1218.  {             IP     }
  1219.  { SP & BPo -> BP     }
  1220.  
  1221.  $16/                 { push   ss        ; Push register arguments          }
  1222.  $54/                 { push   sp                                           }
  1223.  $68/>$C5C5/          { push   $C5C5     ; OldVec.CS Self-modifying code to }
  1224.  $68/>$1919/          { push   $1919     ; OldVec.IP be replaced at run-time}
  1225.  $0F/$A8/             { push   gs                                           }
  1226.  $0F/$A0/             { push   fs                                           }
  1227.  $1E/                 { push   ds                                           }
  1228.  $06/                 { push   es                                           }
  1229.  $9C/                 { pushf                                               }
  1230.  $66/$60/             { pushad                                              }
  1231.  $16/                 { push   ss        ; Stack.Seg (Dummy Return CS)      }
  1232.  $54/                 { push   sp        ; Stack.Ofs (Dummy Return IP)      }
  1233.  $55/                 { push   bp        ; Save SizeOf(Locals)              }
  1234.  $89/$E5/             { mov    bp,sp     ; Set current stack frame          }
  1235.  $83/$46/52/4/        { add    [bp+52],4 ; Correct pushed Regs.SP (BP & SS) }
  1236.  $2B/$66/$00/         { sub    sp,[bp]   ; Make room for Locals             }
  1237.  $8B/$46/56/          { mov    ax,[bp+56]; Correct the pushed BP argument   }
  1238.  $68/>$A157/          { push   $A157     ; AppISR signature (Global DataSeg)}
  1239.  $89/$46/14/          { mov    [bp+14],ax; Regs.BP is now correct.          }
  1240.  $1F);                { pop    ds                                           }
  1241.  
  1242.  {       Flags               }
  1243.  {       CS                  }
  1244.  {       IP                  }
  1245.  {       BP                  }
  1246.  {       Regs                }
  1247.  {       CS dummy (SS)       }
  1248.  {       IP dummy (SP)       }
  1249.  { BP -> BP = SizeOf(Locals) }
  1250.  { SP -> Locals (if any)     }
  1251.  
  1252. procedure ExitISR; inline (                  { Same as real mode ExitDosISR }
  1253.  $89/$EC/             { mov   sp,bp    ; Pop Locals                         }
  1254.  $83/$C4/$06/         { add   sp,6     ; Pop dummy BP,IP and CS             }
  1255.  $66/$61/             { popad          ; Pop registers                      }
  1256.  $9D/                 { popf                                                }
  1257.  $07/                 { pop   es                                            }
  1258.  $1F/                 { pop   ds                                            }
  1259.  $0F/$A1/             { pop   fs                                            }
  1260.  $0F/$A9/             { pop   gs                                            }
  1261.  $83/$C4/10/          { add   sp,10    ; "Pop" IP,CS,SP,SS,BP               }
  1262.  $CF);                { iret           ; Pop IP, CS, Flags                  }
  1263.  
  1264. { EnterCallBack must be the first statement of a DOS -> application callback}
  1265. { you install with the InitDosCallBack function.                            }
  1266.  
  1267. procedure EnterCallBack; inline (
  1268. {$ifdef DPMI}
  1269.  
  1270. { At this point, the stack frame contains the following data:               }
  1271. {                                                                           }
  1272. {       Return Flags                           -----+ Pushed by the         }
  1273. {       Return CS                                   | Real mode callback    }
  1274. {       Return IP                              -----+                       }
  1275. { BP -> Parent Stack frame (BP)                -----+ Pushed by entry code  }
  1276. {       Local variable stack space (if any )   -----+ Reserved by entry code}
  1277. { SP -> Last byte of Local variables (if any)  -----+                       }
  1278.  
  1279.  { Make room on the DPMI stack for the dummy return address and registers }
  1280.  
  1281.  $8B/$46/$00/         { mov   ax,[bp] Return BP needs moving so save in AX  }
  1282.  $83/$ED/$36/         { sub   bp,type Pointer + type TRegisters             }
  1283.  $83/$EC/$36/         { sub   sp,type Pointer + type TRegisters             }
  1284.  
  1285.   { Store the dummy return address and parent stack frame }
  1286.  
  1287.  $89/$46/$00/         { mov   [bp],ax   ; Store relocated return BP         }
  1288.  $89/$76/$02/         { mov   [bp+2],si ; Store pointer to real-mode stack  }
  1289.  $8C/$5E/$04/         { mov   [bp+4],ds ; in the dummy return address space }
  1290.  
  1291.  $06/                 { push  es        ; Save address of TRegisters for    }
  1292.  $57/                 { push  di        ; use by the exit code.             }
  1293.  
  1294.  { Copy TRegisters from DPMI TRegisters (@ES:DI) into the stack arguments }
  1295.  
  1296.  $06/                 { push  es                                            }
  1297.  $89/$FE/             { mov   si,di                                         }
  1298.  $1F/                 { pop   ds               ; DS:SI = @TRegisters        }
  1299.  $B9/>25/             { mov   cx,type TRegisters/2                          }
  1300.  $16/                 { push  ss                                            }
  1301.  $89/$EF/             { mov   di,bp                                         }
  1302.  $07/                 { pop   es               ; ES:DI = SS:BP              }
  1303.  $83/$C7/$06/         { add   di,type Word * 3 ; ES:DI = @EDI               }
  1304.  $FC/                 { cld                                                 }
  1305.  $F3/$A5/             { rep   movsw                                         }
  1306.  
  1307.  { Set DS to the global Pascal Data Segment  }
  1308.  
  1309.  $8E/$5C/$CC);        { mov   ds,[si-(SizeOf(TRegisters)+SizeOf(Word))]     }
  1310.  
  1311. { Now the stack frame contains the following data:                          }
  1312. {                                                                           }
  1313. {       Return Flags                          -----+ Pushed by the DPMI     }
  1314. {       Return CS                                  | Real mode callback     }
  1315. {       Return IP                             -----+                        }
  1316. {       Regs.SS                               -----+                        }
  1317. {       Regs.SP                                    | Registers copied from  }
  1318. {       ...                                        | TRegisters structure   }
  1319. { BP+6  Regs.EDI                              -----+                        }
  1320. { BP+4  Seg(Real-Mode-Stack)                  -----+ PM pointer to top of   }
  1321. { BP+2  Ofs(Real-Mode-Stack)                  -----+ real mode stack        }
  1322. { BP -> Parent Stack frame (BP)               -----+ Pushed by entry code   }
  1323. {       Local variable stack space (if any)   -----+ Reserved by entry code }
  1324. {       Seg(TIntrInfo)                        -----+ Used by the the exit   }
  1325. { SP -> Ofs(TIntrInfo)                        -----+ code                   }
  1326.  
  1327. {$else DPMI}          { Almost the same as EnterISR in real mode }
  1328.  
  1329.  $29/$E5/             { sub   bp,sp    ; BP = SizeOf(Locals)                }
  1330.  $01/$EC/             { add   sp,bp    ; "Pop" Locals off the stack         }
  1331.  
  1332.  {             CS     }
  1333.  {             IP     }
  1334.  { SP & BPo -> BP     }
  1335.  
  1336.  $16/                 { push   ss        ; Push register arguments          }
  1337.  $54/                 { push   sp                                           }
  1338.  $50/                 { push   ax        ; Dummy CS                         }
  1339.  $50/                 { push   ax        ; Dummy IP                         }
  1340.  $0F/$A8/             { push   gs                                           }
  1341.  $0F/$A0/             { push   fs                                           }
  1342.  $1E/                 { push   ds                                           }
  1343.  $06/                 { push   es                                           }
  1344.  $9C/                 { pushf                                               }
  1345.  $66/$60/             { pushad                                              }
  1346.  $16/                 { push   ss        ; Stack.Seg (Dummy Return CS)      }
  1347.  $54/                 { push   sp        ; Stack.Ofs (Dummy Return IP)      }
  1348.  $55/                 { push   bp        ; Save SizeOf(Locals)              }
  1349.  $89/$E5/             { mov    bp,sp     ; Set current stack frame          }
  1350.  $83/$46/52/4/        { add    [bp+52],4 ; Correct pushed Regs.SP (BP & SS) }
  1351.  $2B/$66/$00/         { sub    sp,[bp]   ; Make room for Locals             }
  1352.  $8B/$46/56/          { mov    ax,[bp+56]; Correct the pushed BP argument   }
  1353.  $68/>$DCA1/          { push   $DCA1     ; Callback sig (Global DataSeg)    }
  1354.  $89/$46/14/          { mov    [bp+14],ax; Regs.BP is now correct.          }
  1355.  $1F);                { pop    ds                                           }
  1356.  
  1357.  {       CS                  }
  1358.  {       IP                  }
  1359.  {       BP                  }
  1360.  {       Regs                }
  1361.  {       CS dummy (SS)       }
  1362.  {       IP dummy (SP)       }
  1363.  { BP -> BP = SizeOf(Locals) }
  1364.  { SP -> Locals (if any)     }
  1365.  
  1366. {$endif DPMI}
  1367.  
  1368. { ExitCallBack must be the last statement of a DOS -> application callback  }
  1369. { you install with the InitDosCallBack function.                            }
  1370.  
  1371. procedure ExitCallBack;  inline (
  1372. {$ifdef DPMI}
  1373.  $5F/                 { pop   di       ; Restore ES:DI so they point to the }
  1374.  $07/                 { pop   es       ; RMCB TRegisters set by the DPMI    }
  1375.  
  1376.  $16/                 { push  ss       ; Copy values of the register args   }
  1377.  $89/$EE/             { mov   si,bp    ; from the stack into the TRegisters }
  1378.  $1F/                 { pop   ds       ; DPMI structure.                    }
  1379.  $83/$C6/$06/         { add   si,6     ; DS:SI = @EDI                       }
  1380.  $FC/                 { cld                                                 }
  1381.  $B9/>25/             { mov   cx,type TRegisters/2                          }
  1382.  $F3/$A5/             { rep   movsw                                         }
  1383.  $83/$EF/50/          { sub   di,type TRegisters                            }
  1384.  
  1385.  $C9/                 { leave          ; Pop locals, restore callers BP     }
  1386.  $5E/                 { pop   si       ; Pop dummy return address (pointer  }
  1387.  $1F/                 { pop   ds       ; to top of the real-mode stack).    }
  1388.  $83/$C4/50/          { add   sp,type TRegisters ; "Pop" register arguments }
  1389.  
  1390.  { Set the callback return address CS:IP to the return address as is       }
  1391.  { stored on the top of the realmode stack and "pop" the r/m IP and CS     }
  1392.  
  1393.  $8B/$14/             { mov   dx,[si]                  ; DX = RM return IP  }
  1394.  $8B/$44/$02/         { mov   ax,[si+2]                ; AX = RM return CS  }
  1395.  $26/$89/$55/$2A/     { mov   es:[di+TRegisters.&IP],dx; Set RM return Addr }
  1396.  $26/$89/$45/$2C/     { mov   es:[di+TRegisters.&CS],ax                     }
  1397.  $26/$83/$45/$2E/$04/ { add   es:[di+TRegisters.&SP],4 ; Pop return address }
  1398.  
  1399.  $CF);                { iret                IRET is always used with RMCB's }
  1400.  
  1401. {$else}
  1402.  
  1403.  $89/$EC/             { mov   sp,bp    ; Pop Locals                         }
  1404.  $83/$C4/$06/         { add   sp,6     ; Pop dummy BP,IP and CS             }
  1405.  $66/$61/             { popad          ; Pop registers                      }
  1406.  $9D/                 { popf                                                }
  1407.  $07/                 { pop   es                                            }
  1408.  $1F/                 { pop   ds                                            }
  1409.  $0F/$A1/             { pop   fs                                            }
  1410.  $0F/$A9/             { pop   gs                                            }
  1411.  $83/$C4/10/          { add   sp,10    ; "Pop" IP,CS,SP,SS,BP               }
  1412.  $CB);                { retf           ; Pop IP, CS                         }
  1413. {$endif dpmi}
  1414.  
  1415.  
  1416. { EnterDosISR must be the first statement of hooked DOS/BIOS ISR you install}
  1417. { with the HookDosISR function.                                             }
  1418.  
  1419.  
  1420. procedure EnterDosISR; inline (
  1421.  
  1422. { At this point, the stack frame contains the following data:               }
  1423. {                                                                           }
  1424. {       Return Flags                           -----+ Pushed by the         }
  1425. {       Return CS                                   | Real mode callback    }
  1426. {       Return IP                              -----+                       }
  1427. { BP -> Parent Stack frame (BP)                -----+ Pushed by entry code  }
  1428. {       Local variable stack space (if any )   -----+ Reserved by entry code}
  1429. { SP -> Last byte of Local variables (if any)  -----+                       }
  1430.  
  1431. {$ifdef DPMI}
  1432.  
  1433.  { Make room on the DPMI stack for the dummy return address and registers }
  1434.  
  1435.  $8B/$46/$00/         { mov   ax,[bp] Return BP needs moving so save in AX  }
  1436.  $83/$ED/$36/         { sub   bp,type Pointer + type TRegisters             }
  1437.  $83/$EC/$36/         { sub   sp,type Pointer + type TRegisters             }
  1438.  
  1439.   { Store the dummy return address and parent stack frame }
  1440.  
  1441.  $89/$46/$00/         { mov   [bp],ax   ; Store relocated return BP         }
  1442.  $89/$76/$02/         { mov   [bp+2],si ; Store pointer to real-mode stack  }
  1443.  $8C/$5E/$04/         { mov   [bp+4],ds ; in the dummy return address space }
  1444.  
  1445.  $06/                 { push  es        ; Save address of TRegisters for    }
  1446.  $57/                 { push  di        ; use by the exit code.             }
  1447.  
  1448.  { Copy TRegisters from DPMI TRegisters (@ES:DI) into the stack arguments }
  1449.  
  1450.  $06/                 { push  es                                            }
  1451.  $89/$FE/             { mov   si,di                                         }
  1452.  $1F/                 { pop   ds               ; DS:SI = @TRegisters        }
  1453.  $B9/>25/             { mov   cx,type TRegisters/2                          }
  1454.  $16/                 { push  ss                                            }
  1455.  $89/$EF/             { mov   di,bp                                         }
  1456.  $07/                 { pop   es               ; ES:DI = SS:BP              }
  1457.  $83/$C7/$06/         { add   di,type Word * 3 ; ES:DI = @EDI               }
  1458.  $FC/                 { cld                                                 }
  1459.  $66/$8B/$44/<-12/    { mov   eax,[si-12]      ; (EAX = TIntrInfo.OldVec)   }
  1460.  $F3/$A5/             { rep   movsw                                         }
  1461.  
  1462.  { (Set the CS:IP arguments to the address of the original DOS ISR) }
  1463.  
  1464.  $66/$89/$46/$30/     { mov   dword ptr [Registers.IP],eax                  }
  1465.  
  1466.  { Set DS to the global Pascal Data Segment  }
  1467.  
  1468.  $8E/$5C/$CC);        { mov   ds,[si-(SizeOf(TRegisters)+SizeOf(Word))]     }
  1469.  
  1470. { Now the stack frame contains the following data:                          }
  1471. {                                                                           }
  1472. {       Return Flags                          -----+ Pushed by the DPMI     }
  1473. {       Return CS                                  | Real mode callback     }
  1474. {       Return IP                             -----+                        }
  1475. {       Regs.SS                               -----+ Registers copied from  }
  1476. {       Regs.SP                                    | TRegisters structure   }
  1477. {       Regs.CS (=OldVec.Seg)                      | (except CS & IP)       }
  1478. {       Regs.IP (=OldVec.Ofs)                      |                        }
  1479. {       ...                                        |                        }
  1480. { BP+6  Regs.EDI                              -----+                        }
  1481. { BP+4  Seg(Real-Mode-Stack)                  -----+ PM pointer to top of   }
  1482. { BP+2  Ofs(Real-Mode-Stack)                  -----+ real mode stack        }
  1483. { BP -> Parent Stack frame (BP)               -----+ Pushed by entry code   }
  1484. {       Local variable stack space (if any)   -----+ Reserved by entry code }
  1485. {       Seg(TIntrInfo)                        -----+ Used by the the exit   }
  1486. { SP -> Ofs(TIntrInfo)                        -----+ code                   }
  1487.  
  1488. {$else DPMI}
  1489.  
  1490.  $29/$E5/             { sub   bp,sp      ; BP = SizeOf(Locals)              }
  1491.  $01/$EC/             { add   sp,bp      ; "Pop" Locals off the stack       }
  1492.  
  1493.  {             Flags  }
  1494.  {             CS     }
  1495.  {             IP     }
  1496.  { SP & BPo -> BP     }
  1497.  
  1498.  $16/                 { push   ss        ; Push register arguments          }
  1499.  $54/                 { push   sp                                           }
  1500.  $68/>$C5C5/          { push   $C5C5     ; OldVec.CS Self-modifying code to }
  1501.  $68/>$1919/          { push   $1919     ; OldVec.IP be replaced at run-time}
  1502.  $0F/$A8/             { push   gs                                           }
  1503.  $0F/$A0/             { push   fs                                           }
  1504.  $1E/                 { push   ds                                           }
  1505.  $06/                 { push   es                                           }
  1506.  $9C/                 { pushf                                               }
  1507.  $66/$60/             { pushad                                              }
  1508.  $16/                 { push   ss        ; Stack.Seg (Dummy Return CS)      }
  1509.  $54/                 { push   sp        ; Stack.Ofs (Dummy Return IP)      }
  1510.  $55/                 { push   bp        ; Save SizeOf(Locals)              }
  1511.  $89/$E5/             { mov    bp,sp     ; Set current stack frame          }
  1512.  $83/$46/52/4/        { add    [bp+52],4 ; Correct the pushed Regs.SP       }
  1513.  $2B/$66/$00/         { sub    sp,[bp]   ; Make room for Locals             }
  1514.  $83/$46/$02/$36/     { add    [bp+2],54 ; Dummy Return = @Return_IP        }
  1515.  $8B/$46/56/          { mov    ax,[bp+56]; Correct the pushed BP argument   }
  1516.  $68/>$D150/          { push   $D150     ; DosISR signature (Global DataSeg)}
  1517.  $89/$46/14/          { mov    [bp+14],ax; Regs.BP is now correct.          }
  1518.  $1F);                { pop    ds                                           }
  1519.  
  1520.  {       Flags               }
  1521.  {       CS                  }
  1522.  {       IP                  }
  1523.  {       BP                  }
  1524.  {       Regs                }
  1525.  {       CS dummy (SS)       }
  1526.  {       IP dummy (SP)       }
  1527.  { BP -> BP = SizeOf(Locals) }
  1528.  { SP -> Locals (if any)     }
  1529.  
  1530. {$endif not DPMI}
  1531.  
  1532. { ExitDosISR must be the last statement of hooked DOS/BIOS ISR  you install }
  1533. { with the HookDosISR function.                                             }
  1534.  
  1535. procedure ExitDosISR; inline (
  1536. {$ifdef DPMI}
  1537.  $5F/                 { pop   di       ; Restore ES:DI so they point to the }
  1538.  $07/                 { pop   es       ; RMCB TRegisters set by the DPMI    }
  1539.  
  1540.  $16/                 { push  ss       ; Copy values of the register args   }
  1541.  $89/$EE/             { mov   si,bp    ; from the stack into the TRegisters }
  1542.  $1F/                 { pop   ds       ; DPMI structure.                    }
  1543.  $83/$C6/$06/         { add   si,6     ; DS:SI = @EDI                       }
  1544.  $FC/                 { cld                                                 }
  1545.  $B9/>25/             { mov   cx,type TRegisters/2                          }
  1546.  $F3/$A5/             { rep   movsw                                         }
  1547.  $83/$EF/50/          { sub   di,type TRegisters                            }
  1548.  
  1549.  $C9/                 { leave          ; Pop locals, restore callers BP     }
  1550.  $5E/                 { pop   si       ; Pop dummy return address (pointer  }
  1551.  $1F/                 { pop   ds       ; to top of the real-mode stack).    }
  1552.  $83/$C4/50/          { add   sp,type TRegisters ; "Pop" register arguments }
  1553.  
  1554.   { Set the callback return address CS:IP to the return address as is       }
  1555.   { stored on the top of the realmode stack and "pop" the r/m IP,CS & Flags }
  1556.  
  1557.  $8B/$14/             { mov   dx,[si]                    DX = RM return IP  }
  1558.  $8B/$44/$02/         { mov   ax,[si+2]                  AX = RM return CS  }
  1559.  $26/$89/$55/$2A/     { mov   es:[di+TRegisters.&IP],dx  Set RM return Addr }
  1560.  $26/$89/$45/$2C/     { mov   es:[di+TRegisters.&CS],ax                     }
  1561.  $26/$83/$45/$2E/$06/ { add   es:[di+TRegisters.&SP],6   Pop rtn adr & flags}
  1562.  
  1563.  $CF);                { iret                IRET is always used with RMCB's }
  1564.  
  1565. {$else DPMI}          { Same as ExitISR in real mode }
  1566.  
  1567.  $89/$EC/             { mov   sp,bp    ; Pop Locals             }
  1568.  $83/$C4/$06/         { add   sp,6     ; Pop dummy BP,IP and CS }
  1569.  $66/$61/             { popad          ; Pop registers          }
  1570.  $9D/                 { popf                                    }
  1571.  $07/                 { pop   es                                }
  1572.  $1F/                 { pop   ds                                }
  1573.  $0F/$A1/             { pop   fs                                }
  1574.  $0F/$A9/             { pop   gs                                }
  1575.  $83/$C4/10/          { add   sp,10    ; "Pop" IP,CS,SP,SS,BP   }
  1576.  $CF);                { iret           ; Pop IP, CS, Flags      }
  1577.  
  1578. {$endif dpmi}
  1579.  
  1580. {******************* Programmable Interrupt Timer functions ****************}
  1581.  
  1582. function  GetPit0Count: Word;       { Read value of channel 0 (clock)       }
  1583. function  GetPit1Count: Word;       { Read value of channel 1 (ram refresh) }
  1584. function  GetPit2Count: Word;       { Read value of channel 2 (speaker)     }
  1585.  
  1586. procedure SetPit0Mode(Mode: Word; Value: Word);
  1587. function  GetPit0Mode: Word;        { Only possible with the 8254 !         }
  1588. function  GetPitType: Word;         { Reprograms timer 0 !!                 }
  1589.  
  1590. { Translate a given IRQ number to its corresponding interrupt vector }
  1591.  
  1592. function IRQtoIntVec(IRQ: Byte): Word;
  1593.  
  1594. {*********************** Date/Time related functions ***********************}
  1595.  
  1596. { GetDate returns the current date set in the operating system. Ranges of   }
  1597. { the values returned are: Year 1980-2099, Month 1-12, Day 1-31 and         }
  1598. { DayOfWeek 0-6 (0 corresponds to Sunday).                                  }
  1599.  
  1600. procedure GetDate(var Year,Month,Day,DayOfWeek: Word);
  1601.  
  1602. { SetDate sets the current date in the operating system. Valid parameter    }
  1603. { ranges are: Year 1980-2099, Month 1-12 and Day 1-31. If the date is not   }
  1604. { valid, the function call is ignored.                                      }
  1605.  
  1606. procedure SetDate(Year,Month,Day: Word);
  1607.  
  1608. { GetTime returns the current time set in the operating system. Ranges of   }
  1609. { the values returned are: Hour 0-23, Minute 0-59, Second 0-59 and Sec100   }
  1610. { (hundredths of seconds) 0-99.                                             }
  1611.  
  1612. procedure GetTime(var Hour,Minute,Second,Sec100: Word);
  1613.  
  1614. { SetTime sets the time in the operating system. Valid parameter ranges are:}
  1615. { Hour 0-23, Minute 0-59, Second 0-59 & Sec100 (hundredths of seconds) 0-99.}
  1616. { If the time is not valid, the function call is ignored.                   }
  1617.  
  1618. procedure SetTime(Hour,Minute,Second,Sec100: Word);
  1619.  
  1620. { Formats a date according to local custom - month:day:year  day:month:year }
  1621. { or year:month:day. DosCountry.DateSep character used as separator.        }
  1622.  
  1623. function FormatDate(Year,Month,Day: Word): TDateStr;
  1624.  
  1625. { Formats a time according to local custom - DosCountry.TimeSep character   }
  1626. { used as separator, 12 or 24 hour clock used (DosCountry.TimeFormat)       }
  1627.  
  1628. function FormatTime(Hour,Minute,Second: Word): TTimeStr;
  1629.  
  1630. { Formats a time (including 100ths of seconds) according to local custom -  }
  1631. { DosCountry.TimeSep character used as separator, 12 or 24 hour clock used. }
  1632.  
  1633. function FormatTime100(Hour,Minute,Second,Sec100: Word): TTimeStr;
  1634.  
  1635. {*********************** Disk/Drive related functions **********************}
  1636.  
  1637. { GetVerify returns the state of the verify flag in DOS. When off (False),  }
  1638. { disk writes are not verified. When on (True), all disk writes are verified}
  1639. { to insure proper writing.                                                 }
  1640.  
  1641. function GetVerify: Boolean;
  1642.  
  1643. { SetVerify sets the state of the verify flag in DOS.                       }
  1644.  
  1645. procedure SetVerify(Verify: Boolean);
  1646.  
  1647. { DiskInfo returns information on the given logical drive. Returns false if }
  1648. { the drive number is invalid.                                              }
  1649.  
  1650. function GetDiskInfo(Drive: Byte; var DiskInfo: TDiskInfo): Boolean;
  1651.  
  1652. { DiskFree returns the number of free bytes on the specified drive number   }
  1653. { (0=Default,1=A,2=B,..). DiskFree returns -1 if drive number is invalid.   }
  1654. { MaxLongint (2,147,483,647) is returned on drives with more than 2GB of    }
  1655. { free disk space.                                                          }
  1656.  
  1657. function DiskFree(Drive: Byte): DWord;
  1658.  
  1659. { DiskSize returns the size in bytes of the specified drive number          }
  1660. { (0=Default,1=A,2=B,..). DiskSize returns -1 if the drive number is invalid}
  1661. { MaxLongint (2,147,483,647) is returned on drives larger than 2GB.         }
  1662.  
  1663. function DiskSize(Drive: Byte): DWord;
  1664.  
  1665. { Return the current drive                                                  }
  1666.  
  1667. function GetCurDrive: Char;
  1668.  
  1669. { Returns a list of valid system drives. eg: a return string of 'ABCE' means}
  1670. { drives A: B: C: and E: are valid on this machine. Drive B is not included }
  1671. { on systems with a single floppy drive.                                    }
  1672.  
  1673. function GetDrives: String;
  1674.  
  1675. { Return true if the Drive is valid on the system. False is returned if     }
  1676. { Drive is not an upper or lowercase letter between "A" and "Z" inclusive,  }
  1677. { or the drive does not exist.                                              }
  1678.  
  1679. function DriveValid(Drive: Char): Boolean;
  1680.  
  1681. { Returns true if the drive has removable media. eg if it's a floppy disk,  }
  1682. { CD-Rom etc. False if fixed disk or invalid drive. Drive must be an upper  }
  1683. { or lowercase letter between "A" and "Z"                                   }
  1684.  
  1685. function DriveRemove(Drive: Char): Boolean;
  1686.  
  1687. { Uses the DOS IOCTL functions to return information about a block device.  }
  1688. { Fills in the passed TBlockDevInfo structure and returns the device type.  }
  1689. { A return of 255 indicates an error. (deprecated - use GetVolumeInfo)      }
  1690.  
  1691. function GetDriveInfo(Drive: Char; var Info: TBlockDevInfo): Byte;
  1692.  
  1693. { Validate and return drive type given a drive letter (deprecated - ditto)  }
  1694.  
  1695. function GetDriveType(Drive: Char;
  1696.                       var IsRemoveable, HasChangeLine: Boolean): Byte;
  1697.  
  1698. { Return pointer to the drive volume information record of a given drive.   }
  1699.  
  1700. function GetVolumeInfo(Drive: Char): PVolumeInfo;
  1701.  
  1702. { Determines the volume from the given a path. Path can contain an absolute,}
  1703. { relative or network path. Returns nil and sets a DosError if a valid drive}
  1704. { cannot be resolved from the given Path.                                   }
  1705.  
  1706. function GetVolumeOf(const Path: TNetPath): PVolumeInfo;
  1707. function GetVolumeOfStr(Path: PChar): PVolumeInfo;
  1708.  
  1709. { Add V to List of defined volumes. Called by overridden an CreateVolume.   }
  1710.  
  1711. procedure InsertVolume(V: PVolumeInfo);
  1712.  
  1713. { Check if media on a removable-media drive has been changed }
  1714.  
  1715. function CheckDrvMedia(V: PVolumeInfo): TMediaLevel;
  1716.  
  1717. { Get the volume label of the given drive }
  1718.  
  1719. function GetVolumeLabel(Drive: Char): TVolLabel;
  1720. function GetVolumeLabelStr(VolLabel: PChar; Drive: Char): PChar;
  1721.  
  1722. { Set the volume label of the given drive. Don't include the "." in the name}
  1723.  
  1724. function SetVolumeLabel(Drive: Char; VolLabel: TVolLabel): Boolean;
  1725. function SetVolumeLabelStr(VolLabel: PChar; Drive: Char): Boolean;
  1726.  
  1727. {************************** File related functions *************************}
  1728.  
  1729. { GetFAttr returns the attributes of a file. F must be a file variable      }
  1730. { (typed, untyped or textfile) which has been assigned a name. The          }
  1731. { attributes are examined by ANDing with the attribute masks defined as     }
  1732. { faXXXX constants above. Errors are reported in DosError.                  }
  1733.  
  1734. procedure GetFAttr(var F; var Attr: Word);
  1735.  
  1736. { SetFAttr sets the attributes of a file. F must be a file variable (typed, }
  1737. { untyped or textfile) which has been assigned a name. The attribute value  }
  1738. { is formed by adding (or ORing) the appropriate attribute masks defined as }
  1739. { faXXXX constants above. Errors are reported in DosError.                  }
  1740.  
  1741. procedure SetFAttr(var F; Attr: Word);
  1742.  
  1743. { GetFTime returns the date and time a file was last written. F must be a   }
  1744. { file variable (typed, untyped or textfile) which has been assigned a name.}
  1745. { The file can be open or closed. The Time parameter may be unpacked through}
  1746. { a call to UnpackTime. Errors are reported in DosError.                    }
  1747.  
  1748. procedure GetFTime(var F; var Time: Longint);
  1749.  
  1750. { SetFTime sets the date and time a file was last written. F must be a file }
  1751. { variable (typed, untyped or textfile) which has been assigned and opened. }
  1752. { The Time parameter may be created through a call to PackTime. Errors are  }
  1753. { reported in DosError.                                                     }
  1754.  
  1755. procedure SetFTime(var F; Time: Longint);
  1756.  
  1757. { GetFSize returns the size in bytes of the file assigned to F. F must be   }
  1758. { assigned, but can be open or closed.                                      }
  1759.  
  1760. procedure GetFSize(var F; var Size: Longint);
  1761.  
  1762. { UnAssign disassociates an external file with its File or Text variable.   }
  1763. { Closes an open file before disassociating if the file is still open. Every}
  1764. { variable of type "File" or type "Text" that is assigned must eventually   }
  1765. { have a corresponding call to Unassign, or memory leaks might occur.       }
  1766.  
  1767. procedure UnAssign(var F);
  1768.  
  1769. { Returns the name of an assigned File or Text variable }
  1770.  
  1771. function GetFName(var F): TPathStr;
  1772. function GetFileName(var F): PChar;
  1773.  
  1774. {----------------------- Directory search functions ------------------------}
  1775.  
  1776. { FindFirst searches the specified (or current) directory for the first     }
  1777. { entry that matches the specified filename and attributes. The result is   }
  1778. { returned in the specified search record. Errors (and no files found) are  }
  1779. { reported in DosError. The Low byte of Attr contains the "can have" file   }
  1780. { attributes. The High byte of Attr contains the "must have" file attributes}
  1781.  
  1782. {$ifdef Windows}
  1783. function FindFirst(Path: PChar; Attr: Word; var SR: TSearchRec): Boolean;
  1784. {$else Windows}
  1785. function FindFirst(Path: TPathStr; Attr: Word; var SR: TSearchRec): Boolean;
  1786. function FindFirstStr(Path: PChar; Attr: Word; var SR: TSearchRec): Boolean;
  1787. {$endif Windows}
  1788.  
  1789. { FindNext returs the next entry that matches the name and attributes       }
  1790. { specified in a previous call to FindFirst. The search record must be one  }
  1791. { passed to FindFirst. Errors (and no more files) are reported in DosError. }
  1792.  
  1793. function FindNext(var SR: TSearchRec): Boolean;
  1794.  
  1795. { FindClose terminates a directory search. Does nothing unless long names   }
  1796. { are supported. FindFirst and FindNext call FindClose automatically        }
  1797. { whenever a DOS error occurs (such as deNoMoreFiles), so FindClose only    }
  1798. { needs calling when your code wants a file search to be ended prematurely. }
  1799.  
  1800. procedure FindClose(var SR: TSearchRec);
  1801. {$ifndef LongNames}
  1802.   inline($58/$5A);          { pop   ax dx ; do nothing, just pop ^SR        }
  1803. {$endif LongNames}
  1804.  
  1805. { UnpackTime converts a 4-byte packed date/time returned by FindFirst,      }
  1806. { FindNext or GetFTime into a DateTime record.                              }
  1807.  
  1808. procedure UnpackTime(Time: Longint; var DT: TDateTime);
  1809.  
  1810. { PackTime converts a DateTime record into a 4-byte packed date/time used by}
  1811. { SetFTime.                                                                 }
  1812.  
  1813. procedure PackTime(const DT: TDateTime; var Time: LongInt);
  1814.  
  1815. {------------------- FileName/FilePath name based functions ----------------}
  1816.  
  1817. { FSearch searches for the file given by Path in the list of directories    }
  1818. { given by DirList. The directory paths in DirList must be separated by     }
  1819. { semicolons. Add ';' to start of DirList to start the search in the current}
  1820. { directory of the current drive. The returned value is the fully qualified }
  1821. { path if the Path, or an empty string if the file could not be located.    }
  1822.  
  1823. function FSearch(const Path: String; DirList: String): TPathStr;
  1824. function FileSearch(Dest, Path, DirList: PChar): PChar;
  1825.  
  1826. { FExpand expands the file name in Path into a fully qualified file name.   }
  1827. { The resulting name consists of a drive letter, a colon, a root relative   }
  1828. { directory path, and a file name. Embedded '.' and '..' directory          }
  1829. { references are removed. Wilcards in the name and/or extension are allowed }
  1830. { if the fcWildCard flag is set. Returns ptr to TVolumeInfo for that path.  }
  1831.  
  1832. function FExpand(const Path: String; Flags: Word): TPathStr;
  1833. function FileExpand(Dest, Name: PChar; Flags: Word): PVolumeInfo;
  1834.  
  1835. { FDosExpand returns the DOS 8.3 equivalent of the long file/path name given}
  1836. { by LongPath. Wildcards are not allowed and Path/Name must exist. Used for }
  1837. { passing filename path arguments to child processes.                       }
  1838.  
  1839. function FDosExpand(const Path: TPathStr): TDosPath;
  1840. function FileDosExpand(DosPath, LongPath: PChar): PChar;
  1841.  
  1842. { FContract is the inverse of FExpand. It takes a fully-expanded path and   }
  1843. { tries to convert it to a shorter, current directory relative path.        }
  1844.  
  1845. function FContract(const Path: TPathStr): TPathStr;
  1846. function FileContract(Dest, Name: PChar): PChar;
  1847.  
  1848. { FDosContract is similar to FContract except it returns a DOS 8.3 path.    }
  1849. { Wildcards are not allowed and Name must exist. Use it only for passing    }
  1850. { path arguments to child processes spawned with Exec.                      }
  1851.  
  1852. function FDosContract(const Name: TPathStr): TDosPath;
  1853. function FileDosContract(Dest, Name: PChar): PChar;
  1854.  
  1855. { FSplit splits the file name specified by Path into its three components.  }
  1856. { Dir is set to the drive and directory path with any leading and trailing  }
  1857. { backslashes, Name is set to the file name, and Ext is set to the extension}
  1858. { with a preceding dot. Each of the component strings may possibly be empty,}
  1859. { if Path contains no such component.                                       }
  1860.  
  1861. procedure FSplit(const Path: TPathStr; var Dir: TDirStr; var Name: TNameStr;
  1862.                  var Ext: TExtStr);
  1863. function FileSplit(Path, Dir, Name, Ext: PChar): Word;
  1864.  
  1865. { Compares 2 path strings. Returns +1 if Name1 > Name2,  -1 if Name1 < Name2}
  1866. { and 0 if the file/path names are equivalent. Takes file system case       }
  1867. { sensitiviy into account unless IgnoreCase is true.                        }
  1868.  
  1869. function FCompare(Name1, Name2: String): Integer;
  1870. function FileCompare(Name1, Name2: PChar): Integer;
  1871.  
  1872. { Delete a given file }
  1873.  
  1874. procedure FErase(const FileName: String);
  1875. procedure FileErase(FileName: PChar);
  1876.  
  1877. { Rename a given file to a new name. Can be renamed accross directories but }
  1878. { not accross drives. Errors returned in DosError                           }
  1879.  
  1880. procedure FRename(const OldName, NewName: String);
  1881. procedure FileRename(OldName, NewName: PChar);
  1882.  
  1883. { Get or Set the attributes of a named file }
  1884.  
  1885. function FileGetSetAttr(PathName: PChar; Attr: Word; Op: TAttrOp): Word;
  1886.  
  1887. { Add and remove trailing backslashes from a directory string               }
  1888.  
  1889. procedure DelDirSep(var Dir: TDirStr);
  1890. procedure DelDirSepStr(Dir: PChar);
  1891.  
  1892. procedure AddDirSep(var Dir: TDirStr);
  1893. procedure AddDirSepStr(Dir: PChar);
  1894.  
  1895. { Returns true if S is a directory }
  1896.  
  1897. function IsDirectory(S: TPathStr): Boolean;
  1898. function IsDirectoryStr(S: PChar): Boolean;
  1899.  
  1900. { Returns true if S is a root directory ("X:" or "X:\") }
  1901.  
  1902. function IsRootDir(const S: TPathStr): Boolean;
  1903. function IsRootDirStr(S: PChar): Boolean;
  1904.  
  1905. { Return a unique file name and path, either using the directory in the     }
  1906. { 'TMP' or 'TEMP' environment variables if they exist, or the current       }
  1907. { directory if they don't. Returned file extension is always '.TMP'         }
  1908. { Temp file will be erased on program termination when AutoErase is true.   }
  1909.  
  1910. procedure GetTempFile(var TempName: TPathStr; AutoErase: Boolean);
  1911. procedure GetTempFileStr(TempName: PChar; AutoErase: Boolean);
  1912.  
  1913. { Erases a temporary file whose name was created by GetTempFile             }
  1914.  
  1915. procedure EraseTempFile(const TempName: TPathStr);
  1916. procedure EraseTempFileStr(TempName: PChar);
  1917.  
  1918. { Create a new subdirectory }
  1919.  
  1920. procedure CreateDir(Dir: PChar);
  1921.  
  1922. { Remove an empty directory }
  1923.  
  1924. procedure RemoveDir(Dir: PChar);
  1925.  
  1926. {*********************** Handle based file functions ***********************}
  1927.  
  1928. { FileOpen opens or creates a file. Mode should be a combination of stXXXX  }
  1929. { file open/create and sharing mode constants. Returns a valid file handle  }
  1930. { if successful, or $FFFF if not. Errors are reported in DosError.          }
  1931.  
  1932. function FileOpen(const Name: String; Mode: Word): TFileHandle;
  1933. function FileOpenStr(Name: PChar; Mode: Word): TFileHandle;
  1934.  
  1935. { Close a file previously opened with FileOpen. }
  1936.  
  1937. procedure FileClose(Handle: Word);
  1938.  
  1939. { Return the current file position of a file }
  1940.  
  1941. function FilePosition(Handle: TFileHandle): Longint;
  1942.  
  1943. { Seek to given position relative to start of file }
  1944.  
  1945. function FileSeek(Handle: TFileHandle; Pos: Longint; SeekType: TFileSeek): Longint;
  1946.  
  1947. { Return file size of a file }
  1948.  
  1949. function FileSize(Handle: TFileHandle): Longint;
  1950.  
  1951. { Read Count bytes into Buf from a file. Returns actual number of bytes read}
  1952. { Errors are returned in DosError.                                          }
  1953.  
  1954. function FileRead(Handle: TFileHandle; var Buf; Count: Word): Word;
  1955.  
  1956. { Write Count bytes from Buf into a file. Returns actual number of bytes    }
  1957. { written. Errors are returned in DosError.                                 }
  1958.  
  1959. function FileWrite(Handle: TFileHandle; const Buf; Count: Word): Word;
  1960.  
  1961. { Truncate file at current file position }
  1962.  
  1963. procedure FileTruncate(Handle: TFileHandle);
  1964.  
  1965. { FileGetTime returns the date and time a file was last written. Handle must}
  1966. { be a file handle which has been assigned and opened. The Time parameter   }
  1967. { may be unpacked through a call to UnpackTime. Errors reported in DosError.}
  1968.  
  1969. function FileGetTime(Handle: TFileHandle): Longint;
  1970.  
  1971. { FileSetTime sets the date and time a file was last written. Handle must be}
  1972. { a file handle which has been assigned & opened. The Time parameter may be }
  1973. { created through a call to PackTime. Errors are reported in DosError.      }
  1974.  
  1975. procedure FileSetTime(Handle: TFileHandle; Time: Longint);
  1976.  
  1977. {****************** Environment & Process handling functions ***************}
  1978.  
  1979.  
  1980. { EnvCount returns the number of strings contained in the DOS environment.  }
  1981.  
  1982. function EnvCount: Integer;
  1983.  
  1984. { EnvStr returns a specified environment string. The returned string is of  }
  1985. { the form "VAR=VALUE". The index of the first string is one. If Index is   }
  1986. { less than one or greater than EnvCount, EnvStr returns an empty string.   }
  1987.  
  1988. function EnvStr(Index: Integer): String;
  1989.  
  1990. { GetEnv returns the value of a specified environment variable. The variable}
  1991. { name can be in upper or lowercase, but it must not include the '=' charctr}
  1992. { If the specified environment variable does not exist, GetEnv returns an   }
  1993. { empty string.                                                             }
  1994.  
  1995. function GetEnv(EnvVar: String): String;
  1996.  
  1997. { SwapVectors swaps the contents of the SaveIntXX pointers in the System    }
  1998. { unit with the current contents of the interrupt vectors. SwapVectors is   }
  1999. { typically called just before and just after a call to Exec. This insures  }
  2000. { that the Exec'd process does not use any interrupt handlers installed by  }
  2001. { the current process, and vice versa.                                      }
  2002.  
  2003. {$ifndef Windows}
  2004. procedure SwapVectors;
  2005.  
  2006. { Keep (or Terminate Stay Resident) terminates the program and makes it stay}
  2007. { in memory. The entire program stays in memory, including data segment,    }
  2008. { stack segment, and heap. The ExitCode corresponds to the one passed to the}
  2009. { Halt standard procedure.                                                  }
  2010.  
  2011. procedure Keep(ExitCode: Byte);
  2012.  
  2013. { Exec executes another program. The program is specified by the Path       }
  2014. { parameter, and the command line is specified by the CmdLine parameter. To }
  2015. { execute a DOS internal command, run COMMAND.COM, e.g.                     }
  2016. { "Exec('\COMMAND.COM','/C DIR *.PAS');".  Note the /C in front of the      }
  2017. { command. Errors are reported in DosError. When compiling a program that   }
  2018. { uses Exec, be sure to specify a maximum heap size as there will otherwise }
  2019. { not be enough memory to execute the child process.                        }
  2020.  
  2021. procedure Exec(const Path: String; const CmdLine: TComStr);
  2022.  
  2023. { DosExitCode returns the exit code of a sub-process. The low byte is the   }
  2024. { code sent by the terminating process. The high byte is zero for normal    }
  2025. { termination, 1 if terminated by Ctrl-C, 2 if terminated due to a device   }
  2026. { error, or 3 if terminated by the Keep procedure (function call 31 hex).   }
  2027.  
  2028. function DosExitCode: Word;
  2029. {$endif Windows}
  2030.  
  2031. {*********************** Case-conversion functions *************************}
  2032.  
  2033. { DosUpCase returns the uppercase equivalent of character C, or C if C is   }
  2034. { not a lowercase character.                                                }
  2035.  
  2036. function DosUpCase(C: Char): Char; inline (
  2037.   $5B/                  { pop  bx                       }
  2038.   $B7/$00/              { mov  bh,0                     }
  2039.   $8A/$87/>LoToUpTbl);  { mov  al,[bx+offset LoToUpTbl] }
  2040.  
  2041. { DosLoCase returns the lowercase equivalent of C, or C if C is }
  2042. { not an uppercase character.                                   }
  2043.  
  2044. function DosLoCase(C: Char): Char; inline (
  2045.   $5B/                  { pop  bx                       }
  2046.   $B7/$00/              { mov  bh,0                     }
  2047.   $8A/$87/>UpToLoTbl);  { mov  al,[bx+offset LoToUpTbl] }
  2048.  
  2049. { DosUpperCase converts all lowercase characters in S to their  }
  2050. { lowercase equivalents.                                        }
  2051.  
  2052. procedure DosUpperCase(var S: String);
  2053.  
  2054. { DosLowerCase converts all uppercase characters in S to their  }
  2055. { lowercase equivalents.                                        }
  2056.  
  2057. procedure DosLowerCase(var S: String);
  2058.  
  2059. { DosCompare performs a case insensitive compare of 2 strings }
  2060.  
  2061. function DosCompare(S1, S2: String): Integer;
  2062.  
  2063. {************************* System unit replacements ************************}
  2064.  
  2065. { "Bug Fixed" version of System.ChDir. This function allows strings like    }
  2066. { "A:", "A:\SOMEDIR", "A:SOMEDIR\" etc. System.ChDir only allows  "A:\" and }
  2067. { "A:\SOMEDIR". LFN and network directory paths are supported too of course }
  2068.  
  2069. procedure ChDir(Dir: String);
  2070. procedure ChangeDir(Dir: PChar);
  2071.  
  2072. { Returns the current directory of the specified drive in S. Note that all  }
  2073. { sub-directories are terminated with a backslash, unlike the System unit   }
  2074. { version where only the root directory is terminated with a backslash.     }
  2075. { The case of the path and filenames are converted according to the FileCase}
  2076. { flags, even when compiled without long filename support.                  }
  2077.  
  2078. procedure GetDir(Drive: Byte; var S: String);
  2079. function  GetCurDir(S: PChar; Drive: Byte): PChar;
  2080.  
  2081. {************************ Miscellaneous functions **************************}
  2082.  
  2083. { Return the network name of the local machine }
  2084.  
  2085. function GetLocalName: TMachineName;
  2086.  
  2087. { GetCBreak returns the state of Ctrl-Break checking in DOS. When off       }
  2088. { (False), DOS only checks for Ctrl-Break during I/O to console, printer, or}
  2089. { communication devices. When on (True) checks are made at every system call}
  2090.  
  2091. procedure GetCBreak(var Break: Boolean);
  2092. {$ifdef TurboDos}
  2093. inline (
  2094.   $B8/>$3300/  { mov   ax,3300h        }
  2095.   $CD/$21/     { int   $21             }
  2096.   $5F/         { pop   di              }
  2097.   $07/         { pop   es              }
  2098.   $26/$88/$15);{ mov   byte [es:di],dl }
  2099. {$endif TurboDos}
  2100.  
  2101. { SetCBreak sets the state of Ctrl-Break checking in DOS. }
  2102.  
  2103. procedure SetCBreak(Break: Boolean);
  2104. {$ifdef TurboDos}
  2105. inline (
  2106.   $5A/         { pop   dx              }
  2107.   $B8/>$3301/  { mov   ax,3301h        }
  2108.   $CD/$21);    { int   $21             }
  2109. {$endif TurboDos}
  2110.  
  2111. const
  2112.   rdtsc = $310F;
  2113.  
  2114. function FrdtscW: Word; inline (>rdtsc);  { Clock to edx:eax }
  2115.  
  2116. function FrdtscL: Longint; inline (
  2117.   >rdtsc/           { Clock to edx:eax }
  2118.   $66/$89/$C2/      { mov edx,eax      }
  2119.   $66/$C1/$EA/$10); { shr dx,16        }
  2120.  
  2121. function FrdtscC: Comp; inline (
  2122.   >rdtsc/           { Clock to edx:eax          }
  2123.   $89/$E3/          { mov   bx,sp               }
  2124.   $66/$52/          { push  edx                 }
  2125.   $66/$50/          { push  eax                 }
  2126.   $36/$DF/$6F/$F8/  { fild  qword ptr ss:[bx-8] }
  2127.   $83/$C4/$08);     { add   sp,8                }
  2128.  
  2129. {$ifdef MsDos}
  2130.  
  2131. {************************ XMS Device driver interface **********************}
  2132.  
  2133. { OvrInitXMS loads the overlay file into XMS, if possible. }
  2134.  
  2135. procedure OvrInitXMS;
  2136.  
  2137. {------------------- Low-Level XMS API wrapper functions -------------------}
  2138.  
  2139. { XmsAvail returns total amount of available XMS memory }
  2140.  
  2141. function XmsAvail: Longint;
  2142.  
  2143. { MaxXmsAvail returns the largest available XMS block }
  2144.  
  2145. function MaxXmsAvail: Longint;
  2146.  
  2147. { GetXms allocates a block of XMS memory, and returns a handle to it }
  2148.  
  2149. function GetXms(var Handle: TXmsHandle; var Size: Longint): Boolean;
  2150.  
  2151. { FreeXms deallocates a block of XMS memory }
  2152.  
  2153. function FreeXms(Handle: TXmsHandle): Boolean; inline (
  2154.   $5A/                  { pop    dx            }
  2155.   $B4/$0A/              { mov    ah,xmsFreeEMB }
  2156.   $FF/$1E/>XmsFunc);    { call   [XmsFunc]     }{ Call XmsFreeEMB function  }
  2157.  
  2158. { MoveXms copies data to/from XMS extended memory blocks }
  2159.  
  2160. function MoveXms(Dest: Pointer; DestHandle: TXmsHandle; Srce: Pointer;
  2161.                  SrceHandle: TXmsHandle; Size: Longint): Boolean;
  2162.  
  2163. { ReAllocXms tries to resize a block of XMS extended memory }
  2164.  
  2165. function ReAllocXms(Handle: TXmsHandle; var Size: Longint): Boolean;
  2166.  
  2167. {$endif MsDos}
  2168.  
  2169. {***************************** String functions ****************************}
  2170.  
  2171. { Output a string using DOS function 40h }
  2172.  
  2173. procedure PrintStr(const S: String);
  2174.  
  2175. { Allocate a dynamic string on the heap }
  2176.  
  2177. function NewStr(const S: String): PString;
  2178.  
  2179. { Exchange the values of 2 strings }
  2180.  
  2181. procedure SwapString(var S1, S2: String);
  2182. procedure StrSwap(S1, S2: PChar);
  2183.  
  2184. { Dispose of a string on the heap }
  2185.  
  2186. function DisposeStr(P: PString): Pointer;
  2187.  
  2188. { Dispose of a C-string on the heap }
  2189.  
  2190. procedure StrDispose(Str: PChar);
  2191.  
  2192. { Allocate a C-string on the heap }
  2193.  
  2194. function StrNew(Str: PChar): PChar;
  2195.  
  2196. { Convert a C-string to a Pascal-style string. No length checking performed }
  2197.  
  2198. function StrPas(Str: PChar): String;
  2199.  
  2200. { Copy a string from a C-String. Copies at most MaxLen characters from Str  }
  2201. { to the resulting pascal string. DosError is set to dePathTooLong if       }
  2202. { trancation occurs.                                                        }
  2203.  
  2204. function StrLPas(Str: PChar; MaxLen: Word): String;
  2205.  
  2206. { Copy a Pascal-style string to a null-terminated string }
  2207.  
  2208. function StrPCopy(Dest: PChar; const Source: String): PChar;
  2209.  
  2210. { Convert pascal string to C-String. Copies at most MaxLen chars}
  2211.  
  2212. function StrPLCopy(P: PChar; const PasStr: String; MaxLen: Word): Word;
  2213.  
  2214. { StrScan returns a pointer to the first occurrence of Chr in Str. If Chr   }
  2215. { does not occur in Str, StrScan returns NIL. The null terminator is        }
  2216. { considered to be part of the string.                                      }
  2217.  
  2218. function StrScan(Str: PChar; Chr: Char): PChar;
  2219.  
  2220. { StrRScan returns a pointer to the last occurrence of Chr in Str. If Chr   }
  2221. { does not occur in Str, StrRScan returns NIL. The null terminator is       }
  2222. { considered to be part of the string.                                      }
  2223.  
  2224. function StrRScan(Str: PChar; Chr: Char): PChar;
  2225.  
  2226. { StrCount returns the number of occurences of a given character}
  2227. { in the given string                                           }
  2228.  
  2229. function StrCount(Str: PChar; Chr: Char): Word;
  2230.  
  2231. { StrArrayCount returns the number of occurences of a given character }
  2232. { in the given array of char                                          }
  2233.  
  2234. function StrArrayCount(Str: PChar; Chr: Char; Count: Integer): Word;
  2235.  
  2236. { StrPos returns a pointer to the first occurrence of Str2 in Str1. If Str2 }
  2237. { does not occur in Str1, StrPos returns NIL.                               }
  2238.  
  2239. function StrPos(Str1, Str2: PChar): PChar;
  2240.  
  2241. { StrUpper converts Str to upper case and returns Str.}
  2242.  
  2243. function StrUpper(Str: PChar): PChar;
  2244.  
  2245. { StrLower converts Str to lower case and returns Str.}
  2246.  
  2247. function StrLower(Str: PChar): PChar;
  2248.  
  2249. { Compare two C-strings }
  2250.  
  2251. function StrComp(Str1, Str2: PChar): Integer;
  2252.  
  2253. { Compare two C-strings without case sensitivity }
  2254.  
  2255. function StrIComp(Str1, Str2: PChar): Integer;
  2256.  
  2257. { Compare two C-strings, up to a maximum length }
  2258.  
  2259. function StrLComp(Str1, Str2: PChar; MaxLen: Word): Integer;
  2260.  
  2261. { StrLIComp compares Str1 to Str2, for a maximum length of MaxLen characters}
  2262. { without case sensitivity. The return value is the same as StrComp.        }
  2263.  
  2264. function StrLIComp(Str1, Str2: PChar; MaxLen: Word): Integer;
  2265.  
  2266. { StrCat appends a copy of Source to the end of Dest and returns Dest.      }
  2267.  
  2268. function StrCat(Dest, Source: PChar): PChar;
  2269.  
  2270. { StrLCat appends at most MaxLen - StrLen(Dest) characters from Source to   }
  2271. { the end of Dest, and returns Dest. DosError is set to dePathTooLong if    }
  2272. { trancation occurs.                                                        }
  2273.  
  2274. function StrLCat(Dest, Source: PChar; MaxLen: Word): PChar;
  2275.  
  2276. { StrEnd returns a pointer to the null character that terminates Str.       }
  2277.  
  2278. function StrEnd(Str: PChar): PChar;
  2279.  
  2280. { Copy characters from one string to another }
  2281.  
  2282. function StrCopy(Dest, Source: PChar): PChar;
  2283.  
  2284. { Copy characters from one string to another. Returns pointer to the end of }
  2285. { the resulting string.                                                     }
  2286.  
  2287. function StrECopy(Dest, Source: PChar): PChar;
  2288.  
  2289. { Copy at most MaxLen characters from Source to Dest. DosError is set to    }
  2290. { dePathTooLong if trancation occurs.                                       }
  2291.  
  2292. function StrLCopy(Dest, Source: PChar; MaxLen: Word): Word;
  2293.  
  2294. { Copies characters from one C-string to another.                           }
  2295.  
  2296. function StrMove(Dest, Source: PChar; Count: Word): PChar;
  2297.  
  2298. { Returns the number of characters in Str, excluding the null terminator.   }
  2299.  
  2300. function StrLen(P: PChar): Word;
  2301.  
  2302. {---------------------------------------------------------------------------}
  2303. {---------------------------------------------------------------------------}
  2304.  
  2305. implementation
  2306.  
  2307. {$ifdef MsDos}
  2308.   uses Overlay;
  2309. {$endif MsDos}
  2310.  
  2311. const
  2312.  
  2313. { DeviceAttr bit-fields }
  2314.  
  2315.   bdaNotRemoveable = $0001;       { 1 = Media is not removable              }
  2316.   bdaHasChangeLine = $0002;       { Device supports a change-line           }
  2317.  
  2318. type
  2319.   PIntrInfo = ^TIntrInfo;
  2320.   TIntrInfo = packed record       { Used to register App and O/S interrupts }
  2321.     Next   : PIntrInfo;           { Pointer to next TIntrInfo record        }
  2322.     OldVec : DosPtr;              { Original vector - read only             }
  2323.     UnHook : Pointer;             { Pointer to the UnhookInt function.      }
  2324.     IntNo  : Word;                { Interrupt vector number - read only     }
  2325.   {$ifdef DPMI}
  2326.     DataSeg: Word;                { Global Pascal Data Segment - read only  }
  2327.     Regs   : TRegisters;          { Pseudo registers in a DPMI callback     }
  2328.   {$endif DPMI}
  2329.   end;
  2330.  
  2331.   PCallInfo = ^TCallInfo;
  2332.   TCallInfo = packed record       { Used to register real mode callbacks    }
  2333.     Next   : PIntrInfo;           { Pointer to next TIntrInfo record        }
  2334.     RMCB   : DosPtr;              { Pointer to real mode callback           }
  2335.     UnHook : Pointer;             { Pointer to the UnhookInt function.      }
  2336.     CallNo : Word;                { Callback identifier number - read only  }
  2337.     AppKill: Pointer;             { Pointer to user defined Unhook function }
  2338.     AppHook: Pointer;             { Pointer to user defined Hook function   }
  2339.   {$ifdef DPMI}
  2340.     DataSeg: Word;                { Global Pascal Data Segment - read only  }
  2341.     Regs   : TRegisters;          { TRegisters structure used by the RMCB   }
  2342.   {$endif DPMI}
  2343.   end;
  2344.  
  2345. const
  2346.   itDosInt = 0;                   { Dos (real-mode) interrupt tag           }
  2347. {$ifdef DPMI}
  2348.   itAppInt = 4;                   { Application (Protected mode) intrpt tag }
  2349. {$else DPMI}
  2350.   itAppInt = itDosInt; { Application & O/S interrupt tables are same in r/m }
  2351. {$endif DPMI}
  2352.   itCallBack= 6;                  { Realmode callback                       }
  2353.  
  2354. const
  2355.   DriveList : String[26] = '';    { List of valid disk drives               }
  2356. const
  2357.   IntrRegs: PIntrInfo = nil;
  2358. const
  2359.   SaveDTA: DosPtr = nil;          { Previous address of Dos Transfer Buffer }
  2360. const
  2361.   TempNameCnt: Integer = 0;       { Temporary filename number               }
  2362. const
  2363.   CallNum : Word = itCallBack * 256;  { Used to uniquely identify callbacks }
  2364. const
  2365.   TempNums: Set of Byte = [];     { For erasing temporary files on bad exit }
  2366. const
  2367.   DosChars: TCharSet = ['$','%','-','_','@','{','}','~','`','!','#','&','.',
  2368.                         '^','(',')',' ','0'..'9','A'..'Z']; {Valid 8.3 chars}
  2369.  
  2370. function LongMake(Hi, Lo: Word): Longint; inline (
  2371.   $58/     { pop ax   }
  2372.   $5A);    { pop dx   }
  2373.  
  2374. function Offset(P: Pointer): Word; inline(
  2375.   $58/     { pop  ax  }
  2376.   $5A);    { pop  dx  }
  2377.  
  2378. {$ifndef MsDos}
  2379. function GlobalDosAlloc(Bytes: Longint): Longint; far;
  2380.                         external 'KERNEL' index 184;
  2381.  
  2382. function GlobalDosFree(Selector: Word): Word; far;
  2383.                        external 'KERNEL' index 185;
  2384. {$endif !MsDos}
  2385.  
  2386. function GetDosMem(var Buf: TDosBuf; Size: Word): Boolean;
  2387. {$ifdef MsDos}
  2388. var
  2389.   P,T: Pointer;
  2390. begin
  2391.   Size := (Size + 7) and $FFF8;
  2392.   GetMem(P, Size + 8);
  2393.   if P <> nil then
  2394.   begin
  2395.     if PtrRec(P).Ofs = 0
  2396.      then begin
  2397.             PtrRec(T).Ofs := Size and 15;
  2398.             PtrRec(T).Seg := PtrRec(P).Seg + Size shr 4;
  2399.           end
  2400.      else begin
  2401.             T := P;
  2402.             PtrRec(P).Ofs := 0;
  2403.             Inc(PtrRec(P).Seg);
  2404.           end;
  2405.     FreeMem(T, 8);
  2406.   end;
  2407.   Buf.Buf := P;
  2408. {$else MsDos}
  2409. begin
  2410.   Longint(Buf.RealBuf) := GlobalDosAlloc(Size);
  2411.   Buf.Seg    := Buf.RealOfs;
  2412.   Buf.RealOfs:= 0;
  2413.   Buf.Ofs    := 0;
  2414. {$endif MsDos}
  2415.   Buf.Size  := Size;
  2416.   GetDosMem := Buf.Seg <> 0;
  2417. end;
  2418.  
  2419. procedure FreeDosMem(var Buf: TDosBuf);
  2420. begin
  2421.   if Buf.Seg = 0
  2422.    then Exit;
  2423. {$ifdef MsDos}
  2424.   FreeMem(Buf.Buf, Buf.Size);
  2425.   Buf.Seg := 0;
  2426. {$else MsDos}
  2427.   Buf.Seg := GlobalDosFree(Buf.Seg);
  2428. {$endif MsDos}
  2429.   Buf.Size:= 0;
  2430. end;
  2431.  
  2432. {$ifdef DPMI}
  2433.  
  2434. {$L SOFTINT.OBP}
  2435.  
  2436. function SoftIntr(var Regs: TRegisters): Word; external;    { SOFTINT.OBP }
  2437.  
  2438. {$else DPMI}
  2439.  
  2440. {$L SOFTINT.OBJ}
  2441.  
  2442. function SoftIntr(var Regs: TRegisters): Word;  external;   { SOFTINT.OBJ }
  2443. function DosSoftIntr(var Regs: TRegisters): Word; external; { SOFTINT.OBJ }
  2444. function DosFarCall(var Regs: TRegisters): Word; external;  { SOFTINT.OBJ }
  2445.  
  2446. {$endif DPMI}
  2447.  
  2448. {------------------------- Hook[Dos]Int/InitCallBack -----------------------}
  2449.  
  2450. function UnHookDosI(P: PIntrInfo): Boolean; far;
  2451. begin
  2452. {$ifdef DPMI}
  2453. asm
  2454.            les    di,[P]              { Use the DPMI sever to return the    }
  2455.            mov    ax,dpmiGetRealInt   { real mode address of a real mode    }
  2456.            mov    bx,[es:di+TIntrInfo.IntNo]    { interupt vector (RMCB)    }
  2457.            int    intDPMI
  2458.            mov    ax,dpmiFreeRMCB     { CX:DX = RMCB                        }
  2459.            int    intDPMI             { Release RMCB                        }
  2460. end;
  2461. {$endif DPMI}
  2462.   UnHookDosI := SetDosIntVec(P^.IntNo, P^.OldVec);
  2463.   Dispose(P);
  2464. end;
  2465.  
  2466. function UnHookI(P: PIntrInfo): Boolean; far;
  2467. begin
  2468.   UnHookI := SetIntVec(P^.IntNo, P^.OldVec);
  2469.   Dispose(P);
  2470. end;
  2471.  
  2472. function UnHookCall(P: PCallInfo): Boolean; far;
  2473. begin
  2474.   asm
  2475.             les   di,[P]               { Call user-supplied unhook function }
  2476.             push  [es:di].TCallInfo.CallNo
  2477.             call  [es:di].TCallInfo.AppKill
  2478.             mov   [@Result],al
  2479. {$ifdef DPMI}
  2480.             les   di,[P]
  2481.             mov   dx,[es:di].TCallInfo.RMCB.Word[0]
  2482.             mov   cx,[es:di].TCallInfo.RMCB.Word[2]
  2483.             mov   ax,dpmiFreeRMCB      { CX:DX = RMCB                       }
  2484.             int   intDPMI              { Release RMCB                       }
  2485. {$endif DPMI}
  2486.   end;
  2487.   Dispose(P);
  2488. end;
  2489.  
  2490. { Add an Interrupt, Dos Interrupt or real mode callback to the linked-list. }
  2491. { Duplicate entries are not allowed - ie an interrupt vector that has       }
  2492. { already been hooked by the application cannot be hooked again.            }
  2493.  
  2494. function RegisterIntr(P: PIntrInfo): Boolean; assembler;
  2495. asm
  2496.             push  ds
  2497.     db $66; mov   cx,[IntrRegs].Word[0]     { Save value of IntrRegs ptr    }
  2498.             les   di,[P]               { P must not be a local variable     }
  2499.             lds   si,[IntrRegs]        { DS:DI = @1'st registration record  }
  2500.             mov   ax,[es:di].TIntrInfo.IntNo
  2501.             jmp   @@3
  2502.  
  2503. @@1:        cmp   ax,[si].TIntrInfo.IntNo   { Make sure the IntNo has not   }
  2504.             jne   @@2                       { been hooked already.          }
  2505.             pop   ds
  2506.             mov   al,false
  2507.             jmp   @@Exit
  2508.  
  2509. @@2:        lds   si,[si].TIntrInfo.Next
  2510. @@3:        mov   dx,ds
  2511.             or    dx,si
  2512.             jne   @@1
  2513.  
  2514.             pop   ds
  2515.     db $66; mov   [es:di].TIntrInfo.Next.Word[0],cx { P^.Next := IntrRegs   }
  2516.             mov   [IntrRegs].Word[0],di             { IntrRegs := @P.Next   }
  2517.             mov   [IntrRegs].Word[2],es
  2518.             mov   al,true
  2519. @@Exit:
  2520. end;
  2521.  
  2522. { Unhook the specified Interrupt, Dos Interrupt or real mode callback from  }
  2523. { the system and remove it from the linked-list.                            }
  2524.  
  2525. function UnHookIt: Boolean; far; assembler;  { AX = interrupt identifier    }
  2526. var
  2527.   SaveDS: Word;
  2528. asm
  2529.             mov   [SaveDS],ds
  2530.             mov   si,offset IntrRegs         { DS:SI = address of prev^.Next}
  2531.             les   di,[IntrRegs]              { ES:DI = address of TIntrInfo }
  2532.             jmp   @@2
  2533.  
  2534. @@1:        cmp   ax,[es:di].TIntrInfo.IntNo { DS:SI = address of prev^.Next}
  2535.             je    @@FoundIt                  { ES:DI = address of TIntrInfo }
  2536.             mov   cx,es                      { prev = ThisOne^.Next         }
  2537.             mov   si,di
  2538.             mov   ds,cx                      { DS:SI = @ThisOne^.Next       }
  2539.             les   di,[es:di].TIntrInfo.Next  { ES:DI = @Next TIntrInfo      }
  2540.  
  2541. @@2:        mov   cx,es                      { Make sure we haven't reached }
  2542.             or    cx,di                      { the end of the linked-list   }
  2543.             jne   @@1
  2544.             xor   ax,ax                      { Return false                 }
  2545.             jmp   @@Exit
  2546.  
  2547. @@FoundIt:
  2548.     db $66; mov   ax,word ptr [es:di].TIntrInfo.Next
  2549.             push  es
  2550.     db $66; mov   word ptr [si],ax           { Previous^.Next := This^.Next }
  2551.             push  di
  2552.             mov   ds,[SaveDS]
  2553.             call  [es:di].TIntrInfo.UnHook   { Unhook the ISR/Callback      }
  2554.             mov   al,true
  2555.  
  2556. @@Exit:     mov   ds,[SaveDS]
  2557. end;
  2558.  
  2559. procedure UnHookAll; assembler;       { Unhook all interrupts and callbacks }
  2560. asm                                   { from the system and the linked-list }
  2561. @@Next:     les   di,[IntrRegs]
  2562.             mov   ax,es
  2563.             or    ax,di
  2564.             jz    @@Done
  2565.     db $66; mov   ax,word ptr [es:di].TIntrInfo.Next
  2566.             push  es
  2567.     db $66; mov   word ptr [IntrRegs],ax
  2568.             push  di
  2569.             call  [es:di].TIntrInfo.UnHook
  2570.             jmp   @@Next
  2571.  
  2572. @@Done:     mov   ah,itCallBack
  2573.             mov   [CallNum],ax
  2574. end;
  2575.  
  2576. {$ifndef Windows}
  2577. procedure SwapVectors; assembler;
  2578. var
  2579.   Count: Word;
  2580. asm
  2581.             jmp   @@Start
  2582.  
  2583. @@Callback: pusha                             { Unhook or Hook a callback   }
  2584.             push  es                          { ES:DI = @TCallInfo          }
  2585.             cmp   ah,itCallBack               { AX = Callback identifier    }
  2586.             jne   @@HookCall
  2587.             inc   [es:di].TCallInfo.CallNo.Byte[1] { Next time it's a hook  }
  2588.             push  ax                          { Identifier argument         }
  2589.             call  [es:di].TCallInfo.AppKill   { Unhook the callback         }
  2590.             pop   es
  2591.             popa
  2592.             retn
  2593.  
  2594. @@HookCall: dec   [es:di].TCallInfo.CallNo.Byte[1] { Next time it's unhook  }
  2595.             dec   ah
  2596.     db $66; push  word ptr [es:di].TCallInfo.RMCB
  2597.             push  ax                          { Identifier argument         }
  2598.             call  [es:di].TCallInfo.AppHook   { Re-Hook the callback        }
  2599.             pop   ds
  2600.             pop   es
  2601.             popa
  2602.             retn
  2603.  
  2604.   {$ifdef DPMI}
  2605.  
  2606. @@VecTable: db    $00,2                       { DPMI Exception handler 00   }
  2607.             db    $02,4                       { DPMI Interrupt vector  02   }
  2608.             db    $0C,2                       { DPMI Exception handler 0C   }
  2609.             db    $0D,2                       { DPMI Exception handler 0D   }
  2610.             db    $1B,4                       { DPMI Interrupt vector  1B   }
  2611.             db    $21,4                       { DPMI Interrupt vector  21   }
  2612.             db    $23,0                       { DOS  Interrupt vector  23   }
  2613.             db    $24,0                       { DOS  Interrupt vector  24   }
  2614.             db    $34,4                       { DPMI Interrupt vector  34   }
  2615.             db    $35,4                       { DPMI Interrupt vector  35   }
  2616.             db    $36,4                       { DPMI Interrupt vector  36   }
  2617.             db    $37,4                       { DPMI Interrupt vector  37   }
  2618.             db    $38,4                       { DPMI Interrupt vector  38   }
  2619.             db    $39,4                       { DPMI Interrupt vector  39   }
  2620.             db    $3A,4                       { DPMI Interrupt vector  3A   }
  2621.             db    $3B,4                       { DPMI Interrupt vector  3B   }
  2622.             db    $3C,4                       { DPMI Interrupt vector  3C   }
  2623.             db    $3D,4                       { DPMI Interrupt vector  3D   }
  2624.             db    $3E,4                       { DPMI Interrupt vector  3E   }
  2625.             db    $3F,4                       { DPMI Interrupt vector  3F   }
  2626.             db    $75,4                       { DPMI Interrupt vector  75   }
  2627.  
  2628. @@Start:    les   di,[IntrRegs]
  2629.             mov   si,offset @@VecTable
  2630.  
  2631. @@NextUser: mov   ax,es
  2632.             or    ax,di
  2633.             jz    @@DoneUser
  2634.             mov   bx,[es:di].TIntrInfo.IntNo  { BL = interrupt Number       }
  2635.             cmp   bh,itCallBack               { AH = interrupt/callback type}
  2636.             jb    @@IntCheck                  { Not Hook or UnHook callback }
  2637.             call  @@CallBack                  { Hook/UnHook callback        }
  2638.             jmp   @@NoSwap
  2639.  
  2640. @@IntCheck: mov   si,offset @@VecTable        { Don't swap vectors if a user}
  2641.             mov   cx,21                       { has hooked a std BP interupt}
  2642. @@NxtCheck: cmp   bx,[si]                     { Is it same as a std BP hook?}
  2643.             je    @@NoSwap                    { Yes, so allow std TP swap to}
  2644.             add   si,type Word                { perform the unhooking.      }
  2645.             loop  @@NxtCheck                  { Check all 21 std hooks      }
  2646.  
  2647.             mov   ax,dpmiGetRealInt           { Unhook the user interrupt   }
  2648.             add   al,bh
  2649.             int   intDPMI                     { Get current interrupt vector}
  2650.             xchg  dx,[es:di].TIntrInfo.OldVec.Word[0]
  2651.             xchg  cx,[es:di].TIntrInfo.OldVec.Word[2]
  2652.             inc   ax                          { dmpiGetXXint -> dpmiSetXXint}
  2653.             int   intDPMI                     { Set the interrupt to OldVec }
  2654. @@NoSwap:   les   di,[es:di].TIntrInfo.Next
  2655.             jmp   @@NextUser
  2656.  
  2657. @@DoneUser: mov   si,offset @@VecTable        { Restore BP7 hooked intrpts  }
  2658.             mov   di,offset SaveInt00         { DS:DI = @SaveInt00          }
  2659.             mov   [Count],21                  { There are 21 hooked intrpts }
  2660.  
  2661. @@NextTP:   mov   bx,[cs:si]                  { BL = interrupt Number       }
  2662.             mov   ax,dpmiGetRealInt
  2663.             add   al,bh                       { BH = interrupt/callback type}
  2664.             int   intDPMI                     { CX:DX = current vector      }
  2665.             xchg  [di],dx                     { Save current interrupt vect }
  2666.             xchg  [di+2],cx                   { in SaveIntXX, CX:DX         }
  2667.             inc   al                          { dmpiGetXXint -> dpmiSetXXint}
  2668.             int   intDPMI                     { Set previous interrupt vec  }
  2669.             add   si,type Word                { CS:SI = @next VecTable entry}
  2670.             add   di,type Pointer             { ES:DI = @next SaveIntX var  }
  2671.             dec   [Count]
  2672.             jne   @@NextTP
  2673.   {$else DPMI}
  2674.  
  2675. @@VecTable: db    $00,$02,$1B,$21,$23,$24,$34,$35,$36,$37
  2676.             db    $38,$39,$3A,$3B,$3C,$3D,$3E,$3F,$75
  2677.  
  2678. @@Start:    les   di,[IntrRegs]
  2679.             mov   si,offset @@VecTable
  2680.  
  2681. @@NextUser: mov   ax,es
  2682.             or    ax,di
  2683.             jz    @@DoneUser
  2684.             mov   ax,[es:di].TIntrInfo.IntNo  { AL = interrupt Number       }
  2685.             cmp   ah,itCallBack               { AH = interrupt/callback type}
  2686.             jae   @@IntCheck
  2687.             call  @@CallBack                  { Hook/UnHook callback        }
  2688.             jmp   @@NoSwap
  2689.  
  2690. @@IntCheck: mov   si,offset @@VecTable        { Don't swap vectors if a user}
  2691.             mov   cx,19                       { has hooked a std BP interupt}
  2692. @@NxtCheck: cmp   bx,[si]                     { Is it same as a std BP hook?}
  2693.             je    @@NoSwap                    { Yes, so allow std TP swap to}
  2694.             add   si,type Word                { perform the unhooking.      }
  2695.             loop  @@NxtCheck                  { Check all 19 std hooks      }
  2696.  
  2697.             mov   ah,$35                      { Unhook the user interrupt   }
  2698.             push  es
  2699.             int   intDos                      { ES:BX = current int vector  }
  2700.             mov   dx,bx
  2701.             mov   bx,es                       { BX:DX = current int vector  }
  2702.             pop   es
  2703.             xchg  dx,[es:di].TIntrInfo.OldVec.Word[0]
  2704.             mov   ah,$25                      { DOS - Set interupt vector   }
  2705.             push  ds
  2706.             xchg  bx,[es:di].TIntrInfo.OldVec.Word[2]
  2707.             mov   ds,bx
  2708.             int   intDos
  2709.             pop   ds
  2710.  
  2711. @@NoSwap:   les   di,[es:di].TIntrInfo.Next
  2712.             jmp   @@NextUser
  2713.  
  2714. @@DoneUser: mov   si,offset @@VecTable        { Restore BP7 hooked intrpts  }
  2715.             mov   di,offset SaveInt00         { DS:DI = @SaveInt00          }
  2716.             mov   cx,19
  2717.             cld
  2718. @@NextTP:   mov   ah,$35                      { DOS - Get Interrupt vector  }
  2719.             segcs lodsb                       { AL = interrupt number       }
  2720.             int   intDos                      { ES:BX = current int vector  }
  2721.             push  es
  2722.             push  bx
  2723.             mov   dx,[di]                     { DS:DX = [SaveIntXX]         }
  2724.             push  ds
  2725.             mov   ds,[di+2]
  2726.             mov   ah,$25                      { DOS - Set interrupt vector  }
  2727.             pop   ds
  2728.     db $66; pop   dx                          { EDX = Previous int vector   }
  2729.     db $66; mov   [di],dx
  2730.             add   di,type Pointer
  2731.             loop  @@NextTP
  2732.   {$endif DPMI}
  2733. end;
  2734. {$endif Windows}
  2735.  
  2736. function HookDosIntr(IntNum: Byte; ISR: Pointer): Boolean;
  2737. var
  2738.   P: PIntrInfo;
  2739.   V: DosPtr;
  2740.   R: Boolean;
  2741.   X: Boolean;
  2742. begin
  2743.   R := False;
  2744.   V := GetDosIntVec(IntNum);
  2745.   New(P);
  2746.   with P^ do
  2747.   begin
  2748.     OldVec:= V;                        { Assign the P^.OldVec,              }
  2749.     IntNo := (itDosInt * 256) + IntNum;{ P^.IntNo and the                   }
  2750.     UnHook:= @UnHookDosI;              { UnHook procedure fields.           }
  2751.   end;
  2752.   if RegisterIntr(P) then              { Check the interrupt has not already}
  2753.    asm                                 { been hooked, and add to list.      }
  2754.             push  ds
  2755. {$ifdef DPMI}                          { Allocate an RMCB                   }
  2756.             les   di,[P]
  2757.             mov   [es:di].TIntrInfo.DataSeg,ds
  2758.             lds   si,[ISR]             { DS:SI = Address of PM ISR          }
  2759.             add   di,type TIntrInfo - type TRegisters   { ES:DI = @P^.Regs  }
  2760.             mov   ax,dpmiAllocRMCB     { Allocate real mode callback        }
  2761.             int   intDPMI              { CX:DX = real mode address of RMCB  }
  2762.             jc    @@Exit               { function failed                    }
  2763.             mov   bl,[IntNum]          { Use the DPMI server to set the     }
  2764.             mov   ax,dpmiSetRealInt    { real mode interrupt vector to the  }
  2765.             int   intDPMI              { real mode address of the RMCB.     }
  2766.             jnc   @@Good
  2767.             mov   ax,dpmiFreeRMCB      { Falied to set r/m interrupt vector }
  2768.             int   intDPMI              { o deallocate the allocated RMCB    }
  2769.             jmp   @@Exit
  2770. {$else DPMI}
  2771.             les   di,[ISR]             { Look for the position in the ISR   }
  2772.             mov   al,$68               { (Opcode for push immediate word)   }
  2773.             mov   cx,3                 { of the EnterDosISR macro, so we    }
  2774.             add   di,43                { (minumum offset of push from start)}
  2775.             cld                        { can self-modify the DS place holder}
  2776.             repne scasb                { of the ISR code.                   }
  2777.             mov   ax,ds
  2778.             lds   dx,[ISR]             { DS:DX = address of ISR             }
  2779.             jne   @@Exit               { push immediate opcode not found    }
  2780.             cmp   word ptr [di],$D150
  2781.             jnz   @@Exit               { EnterDosISR Signature not found    }
  2782.  
  2783.             mov   [di],ax              { Store the Data Segment in ISR code }
  2784.             mov   ax,[V].Word[2]       { Store the original Interrupt vector}
  2785.             mov   [di-34],ax           { into the EnterDosISR modified code.}
  2786.             mov   ax,[V].Word[0]       { This means the the CS:IP arguments }
  2787.             mov   [di-31],ax           { of the ISR point to original ISR.  }
  2788.  
  2789.             mov   al,[IntNum]          { AL = interrupt number              }
  2790.             mov   ah,25h               { Use DOS to set a real mode interrpt}
  2791.             int   intDos               { vector to a real mode address.     }
  2792. {$endif DPMI}
  2793.   @@Good:   inc   [R]
  2794.   @@Exit:   pop   ds
  2795.    end;
  2796.   if not R then
  2797.    begin
  2798.      IntrRegs := P^.Next;              { Unhook P from interrupt registratn }
  2799.      Dispose(P);                       { list, then dispose of P.           }
  2800.    end;
  2801.   HookDosIntr := R;
  2802. end;
  2803.  
  2804. function HookIntr(IntNum: Byte; ISR: Pointer): Boolean;
  2805. var
  2806.   P: PIntrInfo;
  2807.   V: Pointer;
  2808.   R: Boolean;
  2809.   X: Boolean;
  2810. begin
  2811.   R := False;
  2812.   V := GetIntVec(IntNum);
  2813.   New(P);
  2814.   with P^ do
  2815.   begin
  2816.     OldVec:= V;                        { Assign the P^.OldVec,              }
  2817.     IntNo := IntNum;                   { P^.IntNo and the                   }
  2818.     UnHook:= @UnHookI;                 { UnHook procedure fields.           }
  2819.   end;
  2820.   if RegisterIntr(P) then              { Check the interrupt has not already}
  2821.    asm                                 { been hooked, and add to list.      }
  2822. {$ifdef DPMI}
  2823.             mov   bx,word ptr [ISR+2]  { Save original ISR code selector    }
  2824.             mov   ax,[SelectorInc]     { Convert the ISR's code segment     }
  2825.             add   word ptr [ISR+2],ax  { selector to a R/W data selector.   }
  2826. {$endif DPMI}
  2827.             push  ds
  2828.             les   di,[ISR]             { Look for the position in the ISR   }
  2829.             mov   al,$68               { (Opcode for push immediate word)   }
  2830.             mov   cx,3                 { of the EnterISR macro, so we can   }
  2831.             add   di,39                { (minumum offset of push from start)}
  2832.             cld                        { self-modify the DS place holder of }
  2833.             repne scasb                { the ISR code.                      }
  2834.             mov   ax,ds
  2835.             lds   dx,[ISR]             { DS:DX = address of ISR             }
  2836.             jne   @@Exit               { push immediate opcode not found    }
  2837.             cmp   word ptr [di],$A157
  2838.             jnz   @@Exit               { EnterISR Signature not found       }
  2839.  
  2840.             mov   [di],ax              { Store the Data Segment in ISR code }
  2841.             mov   ax,[V].Word[2]       { Store the original Interrupt vector}
  2842.             mov   [di-30],ax           { into the EnterISR modified code.   }
  2843.             mov   ax,[V].Word[0]       { This means the the CS:IP arguments }
  2844.             mov   [di-27],ax           { of the ISR point to original ISR.  }
  2845. {$ifdef DPMI}
  2846.             mov   cx,bx                { CX:DX = address of ISR             }
  2847.             mov   ax,dpmiSetProtInt    { Use the DPMI server to set a       }
  2848.             mov   bl,[IntNum]          { protected mode interrupt vector    }
  2849.             int   intDPMI              { to a protected mode address.       }
  2850.             jc    @@Exit
  2851. {$else DPMI}
  2852.             mov   al,[IntNum]          { AL = interrupt number              }
  2853.             mov   ah,25h               { Use DOS to set a real mode         }
  2854.             int   21h                  { interrupt vector real mode address.}
  2855. {$endif DPMI}
  2856.             mov   [R],1
  2857.   @@Exit:   pop   ds
  2858.   end;
  2859.   if not R then
  2860.    begin
  2861.      IntrRegs := P^.Next;             { Unhook P from interrupt registration}
  2862.      Dispose(P);                      { list, then dispose of P.            }
  2863.    end;
  2864.   HookIntr := R;
  2865. end;
  2866.  
  2867. function InitCallBack(CallBackProc, HookProc, UnHookProc: Pointer;
  2868.                       var ID: Word): Boolean;
  2869. var
  2870.   P     : PCallInfo;
  2871.   R     : DosPtr;
  2872.   Result: Boolean;
  2873.   Padder: Boolean;
  2874. begin
  2875.   Result := false;
  2876.   R := nil;
  2877.   New(P);
  2878.   with P^ do
  2879.   begin
  2880. {$ifndef DPMI}
  2881.     RMCB   := CallBackProc;            { Assign the P^.OldVec (not used)    }
  2882. {$endif !DPMI}
  2883.     CallNo := CallNum;                 { P^.CallNo and the                  }
  2884.     UnHook := @UnHookCall;             { UnHook procedure fields.           }
  2885.     AppHook:= HookProc;
  2886.     AppKill:= UnHookProc;
  2887.   end;
  2888.   ID := CallNum;
  2889.   Inc(CallNum);
  2890.   asm
  2891. {$ifdef DPMI}
  2892.             les   di,[P]
  2893.             push  ds
  2894.             mov   [es:di].TCallInfo.DataSeg,ds
  2895.             add   di,offset TCallInfo.Regs  { ES:DI = Address of TRegisters }
  2896.             lds   si,[CallBackProc]    { DS:SI = p/m address of callback    }
  2897.             mov   ax,dpmiAllocRMCB     { Allocate real mode callback        }
  2898.             int   intDPMI              { CX:DX = r/m addr of DPMI callback  }
  2899.             pop   ds
  2900.             jc    @@Exit               { function failed                    }
  2901.             sub   di,offset TCallInfo.Regs               { Store RMCB addr  }
  2902.             mov   PtrRec([es:di.TCallInfo.RMCB]).&Ofs,dx { in P.RMCB        }
  2903.             mov   PtrRec([es:di.TCallInfo.RMCB]).&Seg,cx
  2904.             push  cx                   { CallBackAddr argument to user hook }
  2905.             push  dx
  2906. {$else DPMI}
  2907.             les   di,[CallBackProc]    { Look for the position in CallBack  }
  2908.             mov   al,$68               { (Opcode for push immediate word)   }
  2909.             mov   cx,3                 { of the EnterCallBack macro, so we  }
  2910.             add   di,35                { (minumum offset of push from start)}
  2911.             cld                        { can self-modify the DS place holder}
  2912.             repne scasb                { of the callback code.              }
  2913.             mov   ax,ds
  2914.             jne   @@Exit               { push immediate opcode not found    }
  2915.             cmp   word ptr [es:di],$DCA1
  2916.             je    @@1                  { EnterCallBack Signature not found  }
  2917.             pop   dx                   { so release the allocated RMCB and  }
  2918.             pop   cx                   { fail                               }
  2919.             jmp   @@Exit
  2920.  
  2921.       @@1:  mov   [es:di],ax           { Store the Data Segment in callback }
  2922.             mov   di,PtrRec(CallBackProc).Ofs
  2923.             push  es                   { CallBackAddr argument to HookProc  }
  2924.             push  di
  2925.             les   di,[P]
  2926. {$endif DPMI}                          { Call user-supplied Hook function   }
  2927.             push  [es:di].TCallInfo.CallNo
  2928.             call  [es:di].TCallInfo.AppHook
  2929.             mov   [Result],al
  2930.             cmp   al,false
  2931.             jne   @@Ok                 { Callback was installed succesfully }
  2932. {$ifdef DPMI}
  2933.             les   di,[P]
  2934.             mov   dx,PtrRec([es:di.TCallInfo.RMCB]).&Ofs
  2935.             mov   cx,PtrRec([es:di.TCallInfo.RMCB]).&Seg
  2936.             mov   ax,dpmiFreeRMCB      { CX:DX = RMCB                       }
  2937.             int   intDPMI              { Release RMCB                       }
  2938. {$endif DPMI}
  2939.             jmp   @@Exit
  2940.  
  2941. @@Ok:       db $66; push word ptr [P]
  2942.             call  RegisterIntr         { Add callback to the linked-list    }
  2943.             mov   [Result],true
  2944. @@Exit:
  2945.   end;
  2946.   if not Result then
  2947.    begin
  2948.      Dispose(P);
  2949.      Dec(CallNum);
  2950.    end;
  2951.   InitCallBack := Result;
  2952. end;
  2953.  
  2954. function UnHookDosIntr(IntNum: Byte): Boolean; assembler;
  2955. asm
  2956.             mov   al,[IntNum] { UnHookDosIntr := UnhookIt(itDos or IntNum); }
  2957.             mov   ah,itDosInt
  2958.             push  cs
  2959.             call  near ptr UnhookIt
  2960. end;
  2961.  
  2962. function UnHookIntr(IntNum: Byte): Boolean; assembler;
  2963. asm
  2964.             mov   al,[IntNum]          { UnHookIntr := UnhookIt(IntNum);    }
  2965.             mov   ah,itAppInt
  2966.             push  cs
  2967.             call  near ptr UnhookIt
  2968. end;
  2969.  
  2970. function DoneCallBack(ID: Word): Boolean; assembler;
  2971. asm
  2972.             mov   ax,[ID]              { DoneCallBack := UnhookIt(ID);      }
  2973.             push  cs
  2974.             call  near ptr UnhookIt
  2975. end;
  2976.  
  2977. { Translate a given IRQ number to its corresponding interrupt vector }
  2978.  
  2979. function IRQtoIntVec(IRQ: Byte): Word;
  2980. begin
  2981.   if IRQ < 8
  2982.    then IRQtoIntVec := IRQ + MasterPicBase
  2983.    else if IRQ < 16
  2984.          then IRQtoIntVec := IRQ + SlavePicBase
  2985.          else IRQtoIntVec := Word(-1);
  2986. end;
  2987.  
  2988. {$ifdef MsDos}
  2989.  
  2990. {---------------------------- XMS based routines ---------------------------}
  2991.  
  2992. const
  2993.   xmsGetVersion = $00;     { Get XMS driver version number                  }
  2994.   xmsFreeEMB    = $0A;     { Dispose a block of extended memory             }
  2995.   xmsMoveEMB    = $0B;     { XMS move function                              }
  2996. {$ifdef XMS30}
  2997.   xmsGetFreeEMB = $88;     { Query Free Extended Memory                     }
  2998.   xmsAllocEMB   = $89;     { Allocate a block of extended memory            }
  2999.   xmsReAllocEMB = $8F;     { Resize a block of extended memory              }
  3000.  
  3001. function XmsAvail: Longint; assembler;
  3002. asm
  3003.    db $66; xor    ax,ax
  3004.            mov    ah,xmsGetFreeEMB
  3005.            call   [XmsFunc]
  3006.    db $66; mov    ax,dx
  3007. @@1:
  3008.    db $66; mov    dx,1024; dw 0
  3009.    db $66; mul    dx
  3010.    db $66,$0F,$A4,$C2,$10; { shld edx,eax,16 }
  3011. end;
  3012.  
  3013. { MaxXmsAvail returns the largest available XMS block }
  3014.  
  3015. function MaxXmsAvail: Longint; assembler;
  3016. asm
  3017.    db $66; xor    ax,ax
  3018.            mov    ah,xmsGetFreeEMB
  3019.            call   [XmsFunc]
  3020. @@1:
  3021.    db $66; mov    dx,1024; dw 0
  3022.    db $66; mul    dx
  3023.    db $66,$0F,$A4,$C2,$10; { shld edx,eax,16 }
  3024. end;
  3025.  
  3026. {$else XMS30}
  3027.   xmsGetFreeEMB = $88;     { Query Free Extended Memory                     }
  3028.   xmsAllocEMB   = $89;     { Allocate a block of extended memory            }
  3029.   xmsReAllocEMB = $8F;     { Resize a block of extended memory              }
  3030.  
  3031. function XmsAvail: Longint; assembler;
  3032. asm
  3033.            xor    ax,ax
  3034.            mov    ah,xmsGetFreeEMB
  3035.            call   [XmsFunc]
  3036.            mov    ax,dx
  3037.            mov    dx,1024;
  3038.            mul    dx
  3039. end;
  3040.  
  3041. { MaxXmsAvail returns the largest available XMS block }
  3042.  
  3043. function MaxXmsAvail: Longint; assembler;
  3044. asm
  3045.            xor    ax,ax
  3046.            mov    ah,xmsGetFreeEMB
  3047.            call   [XmsFunc]
  3048.            mov    dx,1024;
  3049.            mul    dx
  3050. end;
  3051. {$endif XMS30}
  3052.  
  3053. function GetXms(var Handle: TXmsHandle; var Size: Longint): Boolean; assembler;
  3054. asm
  3055.            les    di,[Size]
  3056.    db $66; xor    ax,ax
  3057.    db $66; mov    dx,es:[di]           { Convert Size to kilobytes          }
  3058.    db $66; add    dx,1023; dw 0;
  3059.    db $66; shr    dx,10                { E|DX = requested size in kilobytes }
  3060.    db $66; mov    cx,dx                { ECX = Requested size in KB         }
  3061.            mov    ah,xmsAllocEMB       { Call XmsAllocEMB function          }
  3062.            call   [XmsFunc]
  3063.    db $66; shl    cx,10                { ECX = KB-rounded Size in bytes     }
  3064.            or     ax,ax                { Memory allocated ok?               }
  3065.            jnz    @@2                  { Yes                                }
  3066. @@1:       mov    dx,ax                { Return null handle                 }
  3067.    db $66; mov    cx,ax                { Return 0 Size                      }
  3068. @@2:
  3069.    db $66; mov    es:[di],cx           { Return kB-rounded Size in bytes    }
  3070.            les    di,[Handle]
  3071.            mov    es:[di],dx           { Return Handle                      }
  3072. end;
  3073.  
  3074. function MoveXms(Dest: Pointer; DestHandle: TXmsHandle; Srce: Pointer;
  3075.                  SrceHandle: TXmsHandle; Size: Longint): Boolean; assembler;
  3076. type
  3077.   TXmsMove = record
  3078.     Length    : Longint;               { The arguments are set up  as this  }
  3079.     SrceHandle: Word;                  { structure to match  what the Xms   }
  3080.     Srce      : Pointer;               { API function expects. This type    }
  3081.     DestHandle: Word;                  { defined only for debugging.        }
  3082.     Dest      : Pointer;
  3083.   end;
  3084. var
  3085.   M: TXmsMove absolute Size;
  3086. asm
  3087.             xor   ax,ax
  3088.             mov   dx,ds                { Save Turbo's global DS             }
  3089.             mov   ax,ss
  3090.             lea   si,Size              { Get the address of Size            }
  3091.             mov   ds,ax                { Set ds equal to ss                 }
  3092.             mov   es,dx                { Set es to Turbo's ds               }
  3093.             mov   ah,xmsMoveEMB        { Call XMS move function             }
  3094.             call  es:[XmsFunc]
  3095.             mov   ds,dx                { Restore global DS                  }
  3096. @@Exit:    {add   sp,type TXmsMove}
  3097. end;
  3098.  
  3099. function ReAllocXms(Handle: TXmsHandle; var Size: Longint): Boolean; assembler;
  3100. asm
  3101.            les    di,[Size]
  3102.            xor    ax,ax
  3103.    db $66; mov    bx,es:[di]           { EBX = Size in bytes                }
  3104.            mov    ah,xmsReAllocEMB     { Call XmsReAllocEMB function        }
  3105.    db $66; add    bx,1023; dw 0;       { Round Size up to next KB           }
  3106.            mov    dx,[Handle]
  3107.    db $66; shr    bx,10                { EBX = Size in kilobytes            }
  3108.    db $66; mov    cx,bx                { ECX = Size in kilobytes            }
  3109.            call   [XmsFunc]
  3110.    db $66; shl    cx,10                { Convert alloc size to bytes        }
  3111.            cmp    ax,false             { Succesfull call?                   }
  3112.            jne    @@1                  { Yes                                }
  3113.    db $66; xor    cx,cx                { Set Size to 0 (al = false)         }
  3114. @@1:
  3115.    db $66; mov    es:[di],cx           { Size = actual bytes allocated      }
  3116. end;
  3117.  
  3118. type
  3119.   POvrCodeBlock = ^TOvrCodeBlock;
  3120.   TOvrCodeBlock = record
  3121.     Int3F    : Word;      { INT 3F instruction - $CD/$3F                    }
  3122.     RetOfs   : Word;      { Offset of Return                                }
  3123.     FilePos  : Longint;   { Location in overlay file                        }
  3124.     CodeSize : Word;      { Bytes of code in file                           }
  3125.     FixupSize: Word;      { Bytes of relocation data in file                }
  3126.     Entries  : Word;      { Number of entry points                          }
  3127.     NextBlock: Word;      { Next block location (offset from PrefixSeg)     }
  3128.     BufSeg   : Word;      { Segment location in overlay buffer. 0-not loaded}
  3129.     Retries  : Word;      { Called whilst on probation if 1                 }
  3130.     NextSeg  : Word;      { Segment of next loaded code                     }
  3131.     EmsPage  : Word;      { Unused by Xms overlays                          }
  3132.     EmsOffset: Word;
  3133.     Unused   : Word;
  3134.     XmsPos   : Longint;   { Location (offset) in XMS memory Block           }
  3135.   end;
  3136.  
  3137. var
  3138.   OvrXmsHandle: TXmsHandle;                  { XMS handle used by overlays  }
  3139.  
  3140. {= XmsReadBuf ==========================================================}
  3141. { Replacement overlay read routine: gets the overlay code block from    }
  3142. { XMS memory.                                                           }
  3143. {=======================================================================}
  3144.  
  3145. function XmsReadBuf(OvrSeg: Word): Integer; far;
  3146. var
  3147.   CodeBlock: POvrCodeBlock;
  3148.   HeapBlock: PWord;
  3149. begin
  3150.   CodeBlock := Ptr(OvrSeg, 0);
  3151.   HeapBlock := Ptr(CodeBlock^.BufSeg, 0);
  3152.   XmsReadBuf:= Ord(MoveXms(HeapBlock, 0,                      { Destination }
  3153.                    Pointer(CodeBlock^.XmsPos), OvrXmsHandle,  { Source      }
  3154.                    CodeBlock^.CodeSize)) -1;                  { Size        }
  3155. end;
  3156.  
  3157. {= OvrInitXMS ==========================================================}
  3158. { If XMS is present, copy all the code segments into XMS memory. Set up }
  3159. { the OvrReadBuf routine to read them back when required. Close the     }
  3160. { overlay file.                                                         }
  3161. {=======================================================================}
  3162.  
  3163. procedure OvrInitXMS;
  3164. var
  3165.   CodeBlock: POvrCodeBlock;             { Ptr to current overlay code block }
  3166.   OvrBuffer: PWord;                     { Overlay buffer on heap            }
  3167.   OvrTotal : Longint;                   { Xms required for all the overlays }
  3168.   XmsError : Boolean;
  3169.   Padder   : Boolean;
  3170. begin
  3171.   { Exit if no XMS memory or driver }
  3172.  
  3173.   if not XMSinstalled then
  3174.   begin
  3175.     OvrResult := ovrNoXMSDriver;
  3176.     Exit;
  3177.   end;
  3178.  
  3179.   { Exit if the user hasn't called OvrInit }
  3180.  
  3181.   if OvrHeapOrg = 0 then
  3182.   begin
  3183.     OvrResult := ovrError;
  3184.     Exit;
  3185.   end;
  3186.  
  3187.   OvrBuffer := Ptr(OvrHeapOrg, 0);     { Get ptr to overlay buffer on heap  }
  3188.   PtrRec(CodeBlock).Seg := OvrCodeList;{ Walk the overlay code block chain  }
  3189.   PtrRec(CodeBlock).Ofs := 0;
  3190.   OvrTotal := 0;
  3191.   while PtrRec(CodeBlock).Seg <> 0 do
  3192.   begin
  3193.     Inc(PtrRec(CodeBlock).Seg, PrefixSeg + $10);
  3194.     Inc(OvrTotal, (CodeBlock^.CodeSize + 3) and (not 3)); { Round up 2 DWord}
  3195.     PtrRec(CodeBlock).Seg := CodeBlock^.NextBlock; { Next overlay block link}
  3196.   end;
  3197.  
  3198.   { Try to allocate the required amount of XMS memory }
  3199.  
  3200.   if not GetXms(OvrXmsHandle, OvrTotal) then
  3201.   begin
  3202.     OvrResult := ovrNoXMSMemory;       { There was an XMS error             }
  3203.     Exit;
  3204.   end;
  3205.  
  3206.   OvrBuffer := Ptr(OvrHeapOrg, 0);     { Get ptr to overlay buffer on heap  }
  3207.   PtrRec(CodeBlock).Seg := OvrCodeList;{ Walk the overlay code block chain  }
  3208.   OvrTotal := 0;                       { Now it's a running offset          }
  3209.   XmsError := false;
  3210.   while (PtrRec(CodeBlock).Seg <> 0) and (OvrResult = 0) do
  3211.   begin
  3212.     Inc(PtrRec(CodeBlock).Seg, PrefixSeg + $10);
  3213.     with CodeBlock^ do
  3214.     begin
  3215.       BufSeg   := OvrHeapOrg;          { Set block load addr to OvrHeapOrg  }
  3216.       OvrResult:= OvrReadBuf(PtrRec(CodeBlock).Seg); { Load code into memory}
  3217.       BufSeg   := 0;                   { Mark this code block as unloaded   }
  3218.       XmsPos   := OvrTotal;            { Mark the pos in XMS of this overlay}
  3219.       CodeSize := (CodeSize + 3) and (not 3);        { Round up to to DWord }
  3220.       if not MoveXms(Pointer(OvrTotal), OvrXmsHandle,         { Destination }
  3221.                              Ptr(OvrHeapOrg, 0), 0,           { Source      }
  3222.                              CodeSize)                        { Size        }
  3223.        then OvrResult := ovrNoXmsMemory;
  3224.       Inc(OvrTotal, CodeSize);         { = XMS position of next code block  }
  3225.     end;
  3226.     PtrRec(CodeBlock).Seg := CodeBlock^.NextBlock; { Next overlay block link}
  3227.   end;
  3228.  
  3229.   if XmsError
  3230.    then begin                      { There was an XMS error                 }
  3231.           FreeXms(OvrXmsHandle);   { Release the XMS memory block           }
  3232.           OvrXmsHandle := 0;       { Set the handle to zero                 }
  3233.           OvrResult := ovrNoXMSMemory;
  3234.         end
  3235.    else begin
  3236.           asm                      { Close the overlay file, zero the handle}
  3237.             mov   ah,$3E
  3238.             mov   bx,[OvrDOSHandle]
  3239.             int   $21
  3240.           end;
  3241.           OvrDOSHandle:= 0;
  3242.           OvrReadBuf := XmsReadBuf;{ Point the overlay read routine at ours }
  3243.           OvrResult  := 0;
  3244.           XmsOverlays:= true;      { XMS is being used for code overlays    }
  3245.         end;
  3246. end;
  3247. {$endif MsDos}
  3248.  
  3249. {--------------------------- Date and time routines ------------------------}
  3250.  
  3251. procedure GetDate(var Year, Month, Day, DayOfWeek: Word);
  3252. {$ifdef TurboDos}                                         assembler;
  3253. asm
  3254.             mov   ah,$2A                     { DOS - Get System Date        }
  3255.             int   intDos
  3256.             les   di,[DayOfWeek]
  3257.             cbw
  3258.             cld
  3259.             stosw
  3260.             les   di,[Day]
  3261.             mov   al,dl
  3262.             stosw
  3263.             les   di,[Month]
  3264.             mov   al,dh
  3265.             stosw
  3266.             les   di,[Year]
  3267.             mov   [es:di],cx
  3268. end;
  3269. {$else TurboDos}
  3270. var
  3271.   Regs: TRegisters;
  3272. begin
  3273.   ClearRegs(Regs);
  3274.   Regs.AH := $2A;                            { DOS - Get System Date        }
  3275.   DayOfWeek := Lo(MsDos(Regs));
  3276.   Year := Regs.CX;
  3277.   Month:= Regs.DH;
  3278.   Day  := Regs.DL;
  3279. end;
  3280. {$endif TurboDos}
  3281.  
  3282. procedure SetDate(Year, Month, Day: Word);
  3283. {$ifdef TurboDos}                          assembler;
  3284.  asm
  3285.             mov   dl,[Day].Byte[0]
  3286.             mov   ah,$2B                     { DOS - Set System Date        }
  3287.             mov   dh,[Month].Byte[0]
  3288.             mov   cx,[Year]
  3289.             int   intDos
  3290. end;
  3291. {$else TurboDos}
  3292. var
  3293.   Regs: TRegisters;
  3294. begin
  3295.   ClearRegs(Regs);
  3296.   Regs.AH := $2B;                            { DOS - Set System Date        }
  3297.   Regs.CX := Year;
  3298.   Regs.DH := Month;
  3299.   Regs.DL := Day;
  3300.   MsDos(Regs);
  3301. end;
  3302. {$endif TurboDos}
  3303.  
  3304. procedure GetTime(var Hour,Minute,Second,Sec100: Word);
  3305. {$ifdef TurboDos}                                       assembler;
  3306. asm
  3307.             mov   ah,$2C                     { DOS - Get System Time        }
  3308.             int   intDos
  3309.             les   di,[Hour]
  3310.             xor   ax,ax
  3311.             mov   al,ch
  3312.             stosw
  3313.             les   di,[Minute]
  3314.             mov   al,cl
  3315.             stosw
  3316.             les   di,[Second]
  3317.             mov   al,dh
  3318.             stosb
  3319.             les   di,[Sec100]
  3320.             mov   al,dl
  3321.             stosw
  3322. end;
  3323. {$else TurboDos}
  3324. var
  3325.   Regs: TRegisters;
  3326. begin
  3327.   ClearRegs(Regs);
  3328.   Regs.AH := $2C;                            { DOS - Get System Time        }
  3329.   MsDos(Regs);
  3330.   Hour  := Regs.CH;
  3331.   Minute:= Regs.CL;
  3332.   Second:= Regs.DH;
  3333.   Sec100:= Regs.DL;
  3334. end;
  3335. {$endif TurboDos}
  3336.  
  3337. procedure SetTime(Hour, Minute, Second, Sec100: Word);
  3338. {$ifdef TurboDos}                                      assembler;
  3339. asm
  3340.             mov   ch,[Hour].Byte[0]
  3341.             mov   cl,[Minute].Byte[0]
  3342.             mov   dh,[Second].Byte[0]
  3343.             mov   dl,[Sec100].Byte[0]
  3344.             mov   ah,$2D
  3345.             int   intDos
  3346. end;
  3347. {$else TurboDos}
  3348. var
  3349.   Regs: TRegisters;
  3350. begin
  3351.   ClearRegs(Regs);
  3352.   Regs.AH := $2D;                            { DOS - Set System Time        }
  3353.   Regs.CH := Hour;
  3354.   Regs.CL := Minute;
  3355.   Regs.DH := Second;
  3356.   Regs.DL := Sec100;
  3357.   MsDos(Regs);
  3358. end;
  3359. {$endif TurboDos}
  3360.  
  3361. procedure ZeroPad(Value: Word; var S: OpenString; Len: Word);
  3362. var
  3363.   j: Word;
  3364. begin
  3365.   Str(Value:0, S);
  3366.   for j := 1 to Len - Length(S) do
  3367.    S := '0' + S;
  3368. end;
  3369.  
  3370. function FormatDate(Year,Month,Day: Word): TDateStr;
  3371. var
  3372.   Y: String[4];
  3373.   M: String[2];
  3374.   D: String[2];
  3375. begin
  3376.   ZeroPad(Year, Y, 4);
  3377.   ZeroPad(Month, M, 2);
  3378.   ZeroPad(Day, D, 2);
  3379.   case DosCountry.DateFormat of
  3380.     dfUsa:
  3381.       FormatDate := M + DosCountry.DateSep[0] + D + DosCountry.DateSep[0] + Y;
  3382.     dfEurope:
  3383.       FormatDate := D + DosCountry.DateSep[0] + M + DosCountry.DateSep[0] + Y;
  3384.     else { dfJapan }
  3385.       FormatDate := Y + DosCountry.DateSep[0] + M + DosCountry.DateSep[0] + D;
  3386.   end;
  3387. end;
  3388.  
  3389. function FormatTime100(Hour,Minute,Second,Sec100: Word): TTimeStr;
  3390. var
  3391.   H,M,S,S100,AP: String[2];
  3392. begin
  3393.   AP := '';
  3394.   if DosCountry.TimeFormat = tf12Hour then
  3395.    begin
  3396.      AP := 'am';
  3397.      if Hour >= 12 then
  3398.       begin
  3399.         AP[1] := 'p';
  3400.         if Hour > 12
  3401.          then Dec(Hour, 12);
  3402.       end;
  3403.    end;
  3404.   ZeroPad(Hour, H, 2);
  3405.   ZeroPad(Minute, M, 2);
  3406.   ZeroPad(Second, S, 2);
  3407.   ZeroPad(Sec100, S100, 2);
  3408.   FormatTime100 := H + DosCountry.TimeSep[0] + M + DosCountry.TimeSep[0] +
  3409.                    S + DosCountry.TimeSep[0] + S100 + AP;
  3410. end;
  3411.  
  3412. function FormatTime(Hour,Minute,Second: Word): TTimeStr;
  3413. var
  3414.   H,M,S,AP: String[2];
  3415. begin
  3416.   AP := '';
  3417.   if DosCountry.TimeFormat = tf12Hour then
  3418.    begin
  3419.      AP := 'am';
  3420.      if Hour >= 12 then
  3421.       begin
  3422.         AP[1] := 'p';
  3423.         if Hour > 12
  3424.          then Dec(Hour, 12);
  3425.       end;
  3426.    end;
  3427.   ZeroPad(Hour, H, 2);
  3428.   ZeroPad(Minute, M, 2);
  3429.   ZeroPad(Second, S, 2);
  3430.   FormatTime := H + DosCountry.TimeSep[0] + M + DosCountry.TimeSep[0] + S +
  3431.                 AP;
  3432. end;
  3433.  
  3434. {$ifdef DPMI}
  3435.  
  3436. {$L INTR.OBP}           { Software interrupt routines  }
  3437.  
  3438. {$else DPMI}
  3439.  
  3440. {$L INTR.OBJ}           { Software interrupt routines  }
  3441.  
  3442. {$endif DPMI}
  3443.  
  3444. {$ifndef MSDOS}
  3445.  
  3446. function AllocDStoCSAlias(Selector: Word): Word;   far; external 'KERNEL' index 171;
  3447. function AllocSelector(Selector: Word): Word;      far; external 'KERNEL' index 175;
  3448. function FreeSelector(Selector: Word): Word;       far; external 'KERNEL' index 176;
  3449. function ChangeSelector(SourceSelector,
  3450.                         DestSelector: Word): Word; far; external 'KERNEL' index 177;
  3451. function SetSelectorBase(Selector: Word;
  3452.                          Base: Longint): Word;     far; external 'KERNEL' index 187;
  3453. function GetSelectorLimit(Selector: Word): Longint;far; external 'KERNEL' index 188;
  3454. function SetSelectorLimit(Selector: Word;
  3455.                           Limit: Longint): Word;   far; external 'KERNEL' index 189;
  3456.  
  3457. function MapDosPtr(RealPtr: DosPtr): Pointer;
  3458. var
  3459.   Selector: Word;             { Set up a pointer to point to RealPtr memory }
  3460.   Base    : LongInt;
  3461. begin
  3462.   MapDosPtr := nil;
  3463.   Selector := AllocSelector(0);
  3464.   if Selector = 0
  3465.    then Exit;
  3466.   ChangeSelector(CSeg, Selector);            { Ensure a read/write selector }
  3467.   Base := (LongInt(PtrRec(RealPtr).Seg) shl 4);
  3468.   if SetSelectorBase(Selector, Base) = 0 then
  3469.    begin
  3470.      FreeSelector(Selector);
  3471.      Exit;
  3472.    end;
  3473.   SetSelectorLimit(Selector, $FFFF);
  3474.   MapDosPtr := Ptr(Selector, PtrRec(RealPtr).Ofs);
  3475. end;
  3476.  
  3477. {$endif !MSDOS}
  3478.  
  3479. {$ifdef DPMI}
  3480.  
  3481. function  IntrApp(IntNo: Byte; var Regs: TRegisters): Word; external {INTR};
  3482. function  MsDosPM(var Regs: TRegisters): Word; external {INTR};
  3483.  
  3484. {$else DPMI}
  3485.  
  3486. function  Intr(IntNo: Byte; var Regs: TRegisters): Word; external {INTR};
  3487. function  IntrApp(IntNo: Byte; var Regs: TRegisters): Word; external {INTR};
  3488. function  MsDos(var Regs: TRegisters): Word; external {INTR};
  3489.  
  3490. {$endif DPMI}
  3491.  
  3492. {$ifdef Windows}
  3493. procedure AnsiToOem(Dest, Source: PChar); far; external 'KEYBOARD' index $0005;
  3494. procedure OemToAnsi(Dest, Source: PChar); far; external 'KEYBOARD' index $0006;
  3495. {$endif Windows}
  3496.  
  3497. {-------------- General purpose and string conversion functions ------------}
  3498.  
  3499. function Min(A, B: Integer): Integer; inline (
  3500.   $58/                 {pop   ax   }
  3501.   $5B/                 {pop   bx   }
  3502.   $3B/$C3/             {cmp   ax,bx}
  3503.   $7E/$01/             {jle   @@1  }
  3504.   $93);                {xchg  ax,bx}
  3505.                        {@@1:       }
  3506. function MaxWord(A, B: Word): Word; inline (
  3507.   $58/                 {pop   ax   }
  3508.   $5B/                 {pop   bx   }
  3509.   $3B/$C3/             {cmp   ax,bx}
  3510.   $73/$01/             {jae   @@1  }
  3511.   $93);                {xchg  ax,bx}
  3512.                        {@@1:       }
  3513. function MinWord(A, B: Word): Word; inline (
  3514.   $58/                 {pop   ax   }
  3515.   $5B/                 {pop   bx   }
  3516.   $3B/$C3/             {cmp   ax,bx}
  3517.   $76/$01/             {jbe   @@1  }
  3518.   $93);                {xchg  ax,bx}
  3519.                        {@@1:       }
  3520. function MaxLong(A, B: Longint): Longint; inline (
  3521.   $66/$58/             { pop  eax        }
  3522.   $66/$5B/             { pop  ebx        }
  3523.   $66/$3B/$C3/         { cmp  eax,ebx    }
  3524.   $7F/$02/             { jg   @@1        }
  3525.   $66/$93/             { xchg eax,ebx    }
  3526.           {@@1:                   }
  3527.   $66/$0F/$A4/$C2/$10);{ shld edx,eax,16 }
  3528.  
  3529. function LongMul(X, Y: Integer): Longint; inline (
  3530.   $5A/                 { pop  dx  }
  3531.   $58/                 { pop  ax  }
  3532.   $F7/$EA);            { imul dx  }
  3533.  
  3534. function LongMulW(X, Y: Word): Longint; inline (
  3535.   $5A/                 { pop  dx  }
  3536.   $58/                 { pop  ax  }
  3537.   $F7/$E2);            { mul  dx  }
  3538.  
  3539. procedure PrintStr(const S: String);
  3540. begin
  3541.   FileWrite(1, S[1], Length(S));               { Write S to standard output }
  3542. end;
  3543.  
  3544. function NewStr(const S: String): PString;
  3545. var
  3546.   P: PString;
  3547. begin
  3548.   NewStr := nil;
  3549.   if S <> '' then
  3550.    begin
  3551.      GetMem(P, Length(S) + 1);
  3552.      P^ := S;
  3553.      NewStr := P;
  3554.    end;
  3555. end;
  3556.  
  3557. function DisposeStr(P: PString): Pointer;
  3558. begin
  3559.   if P <> nil
  3560.    then FreeMem(P, Length(P^) + 1);
  3561.   DisposeStr := nil;
  3562. end;
  3563.  
  3564. procedure SwapString(var S1, S2: String); assembler;
  3565. asm
  3566.             push  ds
  3567.             les   di,[S2]
  3568.             xor   cx,cx
  3569.             lds   si,[S1]
  3570.             xor   dx,dx
  3571.             mov   al,es:[di]           { AL = Length(S2)                    }
  3572.             mov   dl,[si]              { DX = Length(S1)                    }
  3573.             mov   cl,al                { CX = Length(S2)                    }
  3574.             cmp   dx,cx
  3575.             jle   @@1
  3576.             xchg  dx,cx
  3577. @@1:        inc   cx
  3578. @@2:        xchg  al,[si]
  3579.             inc   si
  3580.             stosb
  3581.             mov   al,es:[di]
  3582.             loop  @@2
  3583.             pop   ds
  3584. end;
  3585.  
  3586. procedure StrSwap(S1, S2: PChar); assembler;
  3587. asm
  3588.             push  ds
  3589.     db $66; push  word ptr [S2]
  3590.             push  cs
  3591.             call  near ptr StrLen
  3592.             push  ax                   { AX = Length(S2)                    }
  3593.     db $66; push  word ptr [S1]
  3594.             push  cs
  3595.             call  near ptr StrLen
  3596.             les   di,[S2]              { AX = Length(S1)                    }
  3597.             pop   cx                   { CX = Length(S2)                    }
  3598.             lds   si,[S1]
  3599.             cmp   ax,cx
  3600.             jle   @@1
  3601.             xchg  ax,cx
  3602. @@1:        inc   cx
  3603. @@2:        mov   al,es:[di]
  3604.             xchg  al,[si]
  3605.             inc   si
  3606.             stosb
  3607.             loop  @@2
  3608.             pop   ds
  3609. end;
  3610.  
  3611. function PasToNull(const S: String; P: PChar): Word; assembler;
  3612. asm
  3613.             push  ds
  3614.             lds   si,[S]               { DS:SI = @Pascal source string      }
  3615.             xor   ax,ax
  3616.             les   di,[P]               { ES:DI = @Null target string        }
  3617.             cld
  3618.             lodsb                      { AX = Length(String)                }
  3619.             mov   cx,ax                { ES:DI = @1st character of source   }
  3620.             jcxz  @@1
  3621.             rep   movsb                { copy CX chars from DS:SI to ES:DI  }
  3622. @@1:        mov   [es:di],cl           { Store the null terminator at end   }
  3623.             pop   ds
  3624. end;
  3625.  
  3626. function StrPCopy(Dest: PChar; const Source: String): PChar; assembler;
  3627. asm
  3628.             push  ds
  3629.             lds   si,[Source]
  3630.             les   di,[Dest]
  3631.             cld
  3632.             mov   bx,di
  3633.             xor   ax,ax
  3634.             mov   dx,es
  3635.             lodsb
  3636.             xchg  ax,cx
  3637.             rep   movsb
  3638.             xor   ax,ax
  3639.             stosb
  3640.             mov   ax,bx
  3641.             pop   ds
  3642. end;
  3643.  
  3644. function StrPLCopy(P: PChar; const PasStr: String;
  3645.                    MaxLen: Word): Word; assembler;
  3646. asm
  3647.             xor   dx,dx
  3648.             push  ds
  3649.             lds   si,[PasStr]          { DS:SI = @Pascal source string      }
  3650.             xor   cx,cx
  3651.             les   di,[P]               { ES:DI = @Null target string        }
  3652.             mov   cl,[si]              { CX = Length(String)                }
  3653.             cld
  3654.             cmp   cx,[MaxLen]
  3655.             jbe   @@1
  3656.             mov   cx,[MaxLen]
  3657.             mov   dx,dePathTooLong
  3658. @@1:        mov   ax,cx                { Return length of string in AX      }
  3659.             inc   si                   { ES:DI = @1st character of source   }
  3660.             rep   movsb                { copy CX chars from DS:SI to ES:DI  }
  3661.             mov   [es:di],cl           { Store the null terminator at end   }
  3662.             pop   ds
  3663.             mov   [StrError],dx
  3664. end;
  3665.  
  3666. function NullToPas(P: PChar): String; assembler;
  3667. asm
  3668.             push  ds
  3669.             les   di,[P]
  3670.         cld
  3671.             mov      cx,-1
  3672.             xor   ax,ax
  3673.             repne scasb
  3674.             not   cx
  3675.             lds   si,[P]
  3676.             dec   cx
  3677.             les   di,@Result
  3678.             mov   al,cl
  3679.             stosb
  3680.             rep   movsb
  3681.             pop   ds
  3682. end;
  3683.  
  3684. function StrLen(P: PChar): Word; assembler;
  3685. asm
  3686.             les   di,[P]
  3687.             mov   cx,-1
  3688.             cld
  3689.             xor   ax,ax
  3690.             repne scasb
  3691.             mov   ax,-2
  3692.             sub   ax,cx
  3693. end;
  3694.  
  3695. function StrMove(Dest, Source: PChar; Count: Word): PChar; assembler;
  3696. asm
  3697.             push  ds
  3698.             lds   si,[Source]
  3699.             les   di,[Dest]
  3700.             mov   ax,di
  3701.             mov   dx,es
  3702.             cld
  3703.             mov   cx,[Count]
  3704.             cmp   si,di
  3705.             jae   @@1
  3706.             std
  3707.             add   si,cx
  3708.             add   di,cx
  3709.             dec   si
  3710.             dec   di
  3711. @@1:        rep   movsb
  3712.             cld
  3713.             pop   ds
  3714. end;
  3715.  
  3716. function StrPas(Str: PChar): String; assembler;
  3717. asm
  3718.             push  ds
  3719.             cld
  3720.             les   di,[Str]
  3721.             mov   cx,$FFFF
  3722.             xor   ax,ax
  3723.             repne scasb
  3724.             not   cx
  3725.             lds   si,[Str]
  3726.             dec   cx
  3727.             les   di,[@Result]
  3728.             mov   ax,cx
  3729.             stosb
  3730.             rep   movsb
  3731.             pop   ds
  3732. end;
  3733.  
  3734. function StrLPas(Str: PChar; MaxLen: Word): String; assembler;
  3735. asm
  3736.             push  ds
  3737.             cld
  3738.             les   di,[Str]
  3739.             xor   ax,ax
  3740.             mov   cx,[MaxLen]
  3741.             mov   dx,ax
  3742.             repne scasb
  3743.             jz    @@1                { Max length not exceeded (found null) }
  3744.             dec   cx                 { Didn't find null, so add 1 to length }
  3745.             mov   dx,dePathTooLong
  3746. @@1:        not   cx
  3747.             add   cx,[MaxLen]
  3748.             les   di,[@Result]
  3749.             lds   si,[Str]
  3750.             mov   ax,cx
  3751.             stosb
  3752.             rep   movsb
  3753.             pop   ds
  3754.             mov   [StrError],dx
  3755. end;
  3756.  
  3757. function StrCopy(Dest, Source: PChar): PChar; assembler;
  3758. asm
  3759.             les   di,[Source]
  3760.             cld
  3761.             push  ds
  3762.             mov   cx,-1
  3763.             xor   ax,ax
  3764.             repne scasb
  3765.             les   di,[Dest]
  3766.             not   cx
  3767.             lds   si,[Source]
  3768.             mov   ax,es
  3769.             mov   dx,di
  3770.             rep   movsb
  3771.             pop   ds
  3772. end;
  3773.  
  3774. function StrECopy(Dest, Source: PChar): PChar; assembler;
  3775. asm
  3776.             les   di,[Source]
  3777.             push  ds
  3778.             mov   cx,-1
  3779.             xor   ax,ax
  3780.             cld
  3781.             repne scasb
  3782.             not   cx
  3783.             lds   si,[Source]
  3784.             les   di,[Dest]
  3785.             rep   movsb
  3786.             mov   ax,di
  3787.             mov   dx,es
  3788.             pop   ds
  3789.             dec   ax
  3790. end;
  3791.  
  3792. function StrLCopy(Dest, Source: PChar; MaxLen: Word): Word; assembler;
  3793. asm
  3794.             les   di,[Source]
  3795.             push  ds
  3796.             mov   cx,[MaxLen]
  3797.             mov   dx,cx
  3798.             cld
  3799.             inc   cx
  3800.             xor   ax,ax
  3801.             repne scasb
  3802.             jz    @@1
  3803.             mov   ax,dePathTooLong
  3804. @@1:        mov   [StrError],ax
  3805.             lds   si,[Source]
  3806.             sub   dx,cx
  3807.             les   di,[Dest]
  3808.             mov   cx,dx
  3809.             rep   movsb
  3810.             stosb
  3811.             mov   ax,dx
  3812.             pop   ds
  3813. end;
  3814.  
  3815. { StrEnd returns a pointer to the null character that           }
  3816. { terminates Str.                                               }
  3817.  
  3818. function StrEnd(Str: PChar): PChar; assembler;
  3819. asm
  3820.             les   di,[Str]
  3821.             cld
  3822.             mov   cx,-1
  3823.             xor   ax,ax
  3824.             repne scasb
  3825.             mov   ax,di
  3826.             mov   dx,es
  3827.             dec   ax
  3828. end;
  3829.  
  3830. function StrCat(Dest, Source: PChar): PChar; assembler;
  3831. asm
  3832.     db $66; push  [Dest].Word[0]
  3833.             push  cs
  3834.             call  near ptr StrEnd
  3835.             push  dx
  3836.             push  ax
  3837.     db $66; push  [Source].Word[0]
  3838.             push  cs
  3839.             call  near ptr StrCopy
  3840.             mov   ax,[Dest].Word[0]
  3841.             mov   dx,[Dest].Word[2]
  3842. end;
  3843.  
  3844. { StrLCat appends at most MaxLen - StrLen(Dest) characters from }
  3845. { Source to the end of Dest, and returns Dest. StrError is set  }
  3846. { to dePathTooLong if trancation occurs                         }
  3847.  
  3848. function StrLCat(Dest, Source: PChar; MaxLen: Word): PChar; assembler;
  3849. asm
  3850.     db $66; push  [Dest].Word[0]
  3851.             push  cs
  3852.             call  near ptr StrEnd                { DS:AX = @Dest[Length]    }
  3853.             mov   cx,[Dest].Word[0]
  3854.             add   cx,MaxLen                      { CX = Highest Dest offset }
  3855.             sub   cx,ax                          { - Ofs(Dest[Len))         }
  3856.             jae   @@1                            { Dest is <= MaxLen        }
  3857.             mov   es,dx                          { Dest is already > MaxLen }
  3858.             mov   di,cx
  3859.             mov   byte ptr [es:di],0             { Truncate Dest            }
  3860.             mov   [StrError],dePathTooLong
  3861.             jmp   @@3
  3862.  
  3863. @@1:        mov   [StrError],deNoError
  3864.             push  dx                             { Append target address    }
  3865.             push  ax
  3866.     db $66; push  [Source].Word[0]               { Append source address    }
  3867.             push  cx                             { Max no. chars to append  }
  3868.     db $66; push  [Source].Word[0]
  3869.             push  cs
  3870.             call  near ptr StrLen                { AX = Length(Source)      }
  3871.             pop   cx                             { CX = MaxCopyChars        }
  3872.             cmp   ax,cx                          { if Len(Source) > MaxChars}
  3873.             jbe   @@2                            { Dest + Source <= MaxLen  }
  3874.             mov   [StrError],dePathTooLong       { StrError := dePathTooLong}
  3875.             mov   ax,cx
  3876. @@2:        push  ax
  3877.             push  cs
  3878.             call  near ptr StrLCopy              { Append Source to Dest    }
  3879.  
  3880. @@3:        mov   ax,[Dest].Word[0]
  3881.             mov   dx,[Dest].Word[2]
  3882. end;
  3883.  
  3884. { StrScan returns a pointer to the first occurrence of Chr in }
  3885. { Str. If Chr does not occur in Str, StrScan returns NIL. The }
  3886. { null terminator is considered to be part of the string.     }
  3887.  
  3888. function StrScan(Str: PChar; Chr: Char): PChar; assembler;
  3889. asm
  3890.             les   di,[Str]
  3891.             cld
  3892.             push  di
  3893.             mov   cx,-1
  3894.             xor   ax,ax
  3895.             repne scasb
  3896.             not   cx
  3897.             pop   di
  3898.             mov   al,[Chr]
  3899.             repne scasb
  3900.             mov   al,0
  3901.             cwd
  3902.             jne   @@Exit
  3903.             dec   di
  3904.             mov   dx,es
  3905.             mov   ax,di
  3906. @@Exit:
  3907. end;
  3908.  
  3909. function StrRScan(Str: PChar; Chr: Char): PChar; assembler;
  3910. asm
  3911.             les   di,[Str]
  3912.             cld
  3913.             mov   cx,-1
  3914.             xor   ax,ax
  3915.             repne scasb
  3916.             not   cx
  3917.             std
  3918.             dec   di
  3919.             mov   al,[Chr]
  3920.             repne scasb
  3921.             mov   al,0
  3922.             cwd
  3923.             jne   @@Exit
  3924.             inc   di
  3925.             mov   dx,es
  3926.             mov   ax,di
  3927. @@Exit:
  3928. end;
  3929.  
  3930. { StrCount returns the number of occurences of a given character}
  3931. { in the given string                                           }
  3932.  
  3933. function StrCount(Str: PChar; Chr: Char): Word; assembler;
  3934. asm
  3935.             les   di,[Str]
  3936.             xor   cx,cx
  3937.             cld
  3938.             dec   cx
  3939.             xor   ax,ax
  3940.             repne scasb
  3941.             mov   ax,-2
  3942.             sub   ax,cx
  3943.             mov   cx,ax
  3944.             xor   dx,dx
  3945.             mov   al,[Chr]
  3946. @@1:        jcxz  @@2
  3947.             repne scasb
  3948.             jne   @@2
  3949.             inc   dx
  3950.             jmp   @@1
  3951.  
  3952. @@2:        mov   ax,dx
  3953. end;
  3954.  
  3955. { StrCharCount returns the number of occurences of a given character}
  3956. { in the given array of char                                        }
  3957.  
  3958. function StrArrayCount(Str: PChar; Chr: Char; Count: Integer): Word; assembler;
  3959. asm
  3960.             les   di,[Str]
  3961.             mov   cx,[Count]
  3962.             cld
  3963.             xor   dx,dx
  3964.             mov   al,[Chr]
  3965. @@1:        jcxz  @@2
  3966.             repne scasb
  3967.             jne   @@2
  3968.             inc   dx
  3969.             jmp   @@1
  3970.  
  3971. @@2:        mov   ax,dx
  3972. end;
  3973.  
  3974. { StrPos returns a pointer to the first occurrence of Str2 in   }
  3975. { Str1. If Str2 does not occur in Str1, StrPos returns NIL.     }
  3976.  
  3977. function StrPos(Str1, Str2: PChar): PChar; assembler;
  3978. asm
  3979.             les   di,[Str2]
  3980.             push  ds
  3981.             cld
  3982.             xor   ax,ax
  3983.             mov   cx,-1
  3984.             repne scasb
  3985.             not   cx
  3986.             dec   cx
  3987.             je    @@2
  3988.             mov   dx,cx
  3989.             mov   bx,es
  3990.             mov   ds,dx
  3991.             les   di,[Str1]
  3992.             mov   bx,di
  3993.             mov   cx,-1
  3994.             repne scasb
  3995.             not   cx
  3996.             sub   cx,dx
  3997.             jbe   @@2
  3998.             mov   di,bx
  3999. @@1:        mov   si,[Str2].Word[0]
  4000.             lodsb
  4001.             repne scasb
  4002.             jne   @@2
  4003.             mov   ax,cx
  4004.             mov   bx,di
  4005.             mov   cx,dx
  4006.             dec   cx
  4007.             repe  cmpsb
  4008.             mov   cx,ax
  4009.             mov   di,bx
  4010.             jne   @@1
  4011.             mov   ax,di
  4012.             mov   dx,es
  4013.             dec   ax
  4014.             jmp   @@Exit
  4015.  
  4016. @@2:        xor   ax,ax
  4017.             xor   dx,dx
  4018. @@Exit:     pop   ds
  4019. end;
  4020.  
  4021. function StrComp(Str1, Str2: PChar): Integer; assembler;
  4022. asm
  4023.             les   di,[Str2]
  4024.             push  ds
  4025.             cld
  4026.             mov   si,di
  4027.             mov   cx,-1
  4028.             xor   ax,ax
  4029.             cwd
  4030.             repne scasb
  4031.             not   cx
  4032.             mov   di,si
  4033.             lds   si,[Str1]
  4034.             repe  cmpsb
  4035.             mov   al,[si-1]
  4036.             mov   dl,es:[di-1]
  4037.             pop   ds
  4038.             sub   ax,dx
  4039. end;
  4040.  
  4041. function StrLComp(Str1, Str2: PChar; MaxLen: Word): Integer; assembler;
  4042. asm
  4043.             les   di,[Str2]
  4044.             push  ds
  4045.             cld
  4046.             mov   si,di
  4047.             mov   ax,[MaxLen]
  4048.             mov   cx,ax
  4049.             jcxz  @@Exit
  4050.             mov   bx,ax
  4051.             xor   ax,ax
  4052.             xor   dx,dx
  4053.             repne scasb
  4054.             mov   di,si
  4055.             sub   bx,cx
  4056.             lds   si,[Str1]
  4057.             mov   cx,bx
  4058.             repe  cmpsb
  4059.             mov   al,[si-1]
  4060.             mov   dl,es:[di-1]
  4061.             sub   ax,dx
  4062. @@Exit:     pop   ds
  4063. end;
  4064.  
  4065. function StrLIComp(Str1, Str2: PChar; MaxLen: Word): Integer; assembler;
  4066. var
  4067.   SaveDS: Word;
  4068. asm
  4069.             les   di,[Str2]
  4070.             mov   [SaveDS],ds
  4071.             cld
  4072.             mov   ax,[MaxLen]
  4073.             mov   si,di                     { Save Str2.Ofs in SI           }
  4074.             mov   cx,ax                     { Count := MaxLen               }
  4075.             jcxz  @@Exit                    { MaxLen = 0, so StrLIComp = 0  }
  4076.             mov   bx,ax                     { Save MaxLen in BX             }
  4077.             xor   ax,ax
  4078.             xor   dx,dx
  4079.             repne scasb                     { Look for Str2 null terminator }
  4080.             sub   bx,cx                     { BX = Min(MaxLen, StrLen(Str2))}
  4081.             mov   cx,bx
  4082.             mov   di,si                     { ES:DI = addr(Str2)            }
  4083.             lds   si,[Str1]                 { DS:SI = addr(Str1)            }
  4084.             xor   bx,bx                     { BH = 0                        }
  4085. @@1:        repe  cmpsb
  4086.             je    @@Exit
  4087.             push  ds
  4088.             mov   bl,[si-1]
  4089.             mov   ds,[SaveDS]
  4090.             mov   al,[bx+offset LoToUpTbl]  { AL = DosUpCase[AL]            }
  4091.             mov   bl,[es:di-1]
  4092.             mov   bl,[bx+offset LoToUpTbl]  { BL = DosUpCase[BL]            }
  4093.             sub   ax,bx
  4094.             pop   ds
  4095.             jz    @@1
  4096. @@Exit:     mov   ds,[SaveDS]
  4097. end;
  4098.  
  4099. function Compare(const Arg1, Arg2; Length: Word): Integer; assembler;
  4100. asm
  4101.             les   di,[Arg1]
  4102.             push  ds
  4103.             lds   si,[Arg2]
  4104.             cld
  4105.             mov   cx,[Length]
  4106.             xor   ax,ax
  4107.             repe  cmpsb
  4108.             je    @@Exit
  4109.             adc   al,0
  4110.             jne   @@Exit
  4111.             not   ax
  4112. @@Exit:     pop   ds
  4113. end;
  4114.  
  4115. function DosCompare(S1, S2: String): Integer;
  4116. var
  4117.   Result: Integer;
  4118.   L1,L2 : Word;
  4119. begin
  4120.   DosUppercase(S1);
  4121.   DosUppercase(S2);
  4122.   L1 := Length(S1);
  4123.   L2 := Length(S2);
  4124.   Result := Compare(S1[1], S2[1], Min(Length(S1), Length(S2)));
  4125.   if (Result = 0) and (L1 <> L2)
  4126.    then Result := -1 + (Ord(L1 > L2) shl 1);
  4127.   DosCompare := Result;
  4128. end;
  4129.  
  4130. function StrIComp(Str1, Str2: PChar): Integer;
  4131. var
  4132.   Result: Integer;
  4133.   L1,L2 : Word;
  4134.   J     : Word;
  4135.   C1,C2 : Char;
  4136. begin
  4137.   L1 := StrLen(Str1);
  4138.   L2 := StrLen(Str2);
  4139.   for J := MinWord(L1, L2)-1 downto 0 do
  4140.    begin
  4141.      C1 := DosUpCase(Str1^);
  4142.      C2 := DosUpCase(Str1^);
  4143.      if (C1 <> C2)
  4144.       then Break;
  4145.      Inc(Str1);
  4146.      Inc(Str2);
  4147.    end;
  4148.   Result := 0;
  4149.   if C1 < C2
  4150.    then Dec(Result)
  4151.    else if C1 > C2
  4152.          then Inc(Result)
  4153.          else if L1 <> L2
  4154.                then Result := -1 + (Ord(L1 > L2) shl 1);
  4155.   StrIComp := Result;
  4156. end;
  4157.  
  4158. function StrNew(Str: PChar): PChar;
  4159. var
  4160.   L: Word;
  4161.   P: PChar;
  4162. begin
  4163.   StrNew := nil;
  4164.   if (Str <> nil) and (Str^ <> #0) then
  4165.   begin
  4166.     L := StrLen(Str) + 1;
  4167.     GetMem(P, L);
  4168.     if P <> nil
  4169.      then StrNew := StrMove(P, Str, L);
  4170.   end;
  4171. end;
  4172.  
  4173. procedure StrDispose(Str: PChar);
  4174. begin
  4175.   if Str <> nil
  4176.    then FreeMem(Str, StrLen(Str) + 1);
  4177. end;
  4178.  
  4179. procedure RunErr(ErrCode: Word); far;
  4180. begin
  4181.   RunError(ErrCode);
  4182. end;
  4183.  
  4184. procedure CheckDosBuf(var SaveBuf; MinBufSize: Word); assembler;
  4185. asm
  4186.             cmp   [DosBuf.Size],0
  4187.             jne   @@1
  4188.             push  cs
  4189.             call  near ptr DosInit
  4190. @@1:        mov   cx,[MinBufSize]
  4191.             cmp   cx,[DosBuf.Size]
  4192.             jbe   @@2
  4193.             pop   ds
  4194.             push  deBadMemBlock
  4195.             call  RunErr
  4196.  
  4197. @@2:        les   di,[SaveBuf]
  4198.             push  ds
  4199.             lds   si,[DosBuf.Buf]
  4200.             cld
  4201.             shr   cx,1
  4202.             rep   movsw
  4203.             jnc   @@3
  4204.             movsb
  4205. @@3:        pop   ds
  4206. end;
  4207.  
  4208. procedure RestoreDosBuf(const SaveBuf; BufSize: Word); assembler;
  4209. asm
  4210.             push  ds
  4211.             les   di,[DosBuf.Buf]
  4212.             lds   si,[SaveBuf]
  4213.             mov   cx,[BufSize]
  4214.             cld
  4215.             shr   cx,1
  4216.             rep   movsw
  4217.             jnc   @@1
  4218.             movsb
  4219. @@1:        pop   ds
  4220. end;
  4221.  
  4222. {------------------------- Environment string handling ---------------------}
  4223.  
  4224. procedure IndexEnvStr; assembler;
  4225. asm
  4226.             mov   es,[PrefixSeg]
  4227.             xor   di,di
  4228.             mov   es,[es:02Ch]         { Load ES with environment seg       }
  4229.             cld
  4230.             xor   ax,ax
  4231. @@1:        cmp   al,[es:di]           { If 1st byte null, or double null   }
  4232.             je    @@Exit               { then last environment string done  }
  4233.             dec   dx
  4234.             jz    @@Exit
  4235.             mov   cx,-1                { Find next null terminator          }
  4236.             repne scasb
  4237.             jmp   @@1
  4238.  
  4239. @@Exit:     or    dx,dx
  4240. end;
  4241.  
  4242. function EnvCount: Integer; assembler;
  4243. asm
  4244.             xor   dx,dx
  4245.             call  IndexEnvStr
  4246.             neg   dx
  4247.             mov   ax,dx
  4248. end;
  4249.  
  4250. function EnvStr(Index: Integer): String; assembler;
  4251. asm
  4252.             les   si,[@Result]
  4253.             mov   dx,[Index]
  4254.             mov   [byte ptr es:si],0
  4255.             dec   dx
  4256.             mov   bx,es               { Save Result segment                 }
  4257.             js    @@Exit              { Invalid index                       }
  4258.             inc   dx
  4259.             call  IndexEnvStr
  4260.             jnz   @@Exit              { Invalid index                       }
  4261.             push  bx                  { BX:SI = @Result                     }
  4262.             push  si
  4263.             push  es                  { ES:@DI = @EnvStr[Index]             }
  4264.             push  di
  4265.             call  NullToPas           { Convert to Pascal style string      }
  4266. @@Exit:
  4267. end;
  4268.  
  4269. function GetEnv(EnvVar: String): String;
  4270. var
  4271.   S,E : String;
  4272.   i,j : Integer;
  4273. begin
  4274.   DosUpperCase(EnvVar);
  4275.   GetEnv := '';
  4276.   i := EnvCount;
  4277.   while i > 0 do
  4278.    begin
  4279.      S := EnvStr(i);
  4280.      j := Pos('=', S);
  4281.  
  4282.      E := Copy(S, 1, j-1);
  4283.      DosUpperCase(E);
  4284.      if E = EnvVar then
  4285.       begin
  4286.         GetEnv := Copy(S, j+1, 255);
  4287.         Break;
  4288.       end;
  4289.      Dec(i);
  4290.    end;
  4291. end;
  4292.  
  4293. {----------------------- Replacement System functions ----------------------}
  4294.  
  4295. {$ifdef MsDos}
  4296. function GetExtError: Word; assembler; { Return extended DOS err in AX & BX }
  4297. asm
  4298.             mov   ax,seg @Data
  4299.             push  ds
  4300.             push  bp
  4301.             push  es
  4302.             push  di
  4303.             mov   ah,$59
  4304.             mov   ds,ax
  4305.             push  ds
  4306.             int   intDos
  4307.             pop   di
  4308.             pop   es
  4309.             pop   ds
  4310.             pop   bp
  4311. @@1:        mov   [DosError],ax
  4312.             mov   bx,ax
  4313.             pop   ds
  4314. end;
  4315. {$else MsDos}
  4316. function GetExtError: Word;            { Return extended DOS err in AX & BX }
  4317. var
  4318.   Regs: TRegisters;
  4319. begin
  4320.   ClearRegs(Regs);
  4321.   Regs.AH    := $59;                   { DOS - Get extended error code      }
  4322.   DosError   := MsDos(Regs);
  4323.   DosErrClass:= Regs.BX;
  4324.   DosErrLocus:= Regs.CH;
  4325.   GetExtError:= Regs.AX;
  4326.   asm
  4327.             mov   ax,[DosError]
  4328.             mov   bx,ax
  4329.   end;
  4330. end;
  4331. {$endif MsDos}
  4332.  
  4333. type
  4334.   TPathName  = packed array[0..fsPathName] of Char;
  4335.   TPathNet   = packed array[0..fsNetPath] of Char;
  4336.  
  4337.   TShortPath = packed array[0..fsDosPath] of Char;
  4338.   TShortName = packed array[0..fsDosName] of Char;
  4339.   TShortDir  = packed array[0..fsDosDir] of Char;
  4340.  
  4341.   PRename = ^TRename;             { Structure used by Rename and FRename    }
  4342.   TRename = packed record
  4343.     Old: TPathNet;
  4344.     New: TPathNet;
  4345.   end;
  4346.  
  4347.   PNetNet  = ^TNetNet;            { For converting a short or net path to a }
  4348.   TNetNet = record                { long path.                              }
  4349.     LongPath: TPathNet;           { used by DOS "GetTrueName" so            }
  4350.     NetPath : TPathNet;           { result (LongPath) cound be net          }
  4351.   end;
  4352.  
  4353. procedure SlashConvert(Length: Word; var Path); assembler;
  4354. asm
  4355.             les   di,[Path]
  4356.             mov   cx,[Length]
  4357.             mov   al,'/'
  4358.             cld
  4359. @@1:        jcxz  @@Exit
  4360.             repne scasb
  4361.             jnz   @@Exit
  4362.             mov   byte ptr [es:di-1],'\'
  4363.             jmp   @@1
  4364.  
  4365.             mov   di,[Path].Word[0]    { @Path in ES:DI                     }
  4366. @@Exit:     mov   cx,[Length]          { Returns with Length in CX and      }
  4367. end;
  4368.  
  4369. function IsDosName(P: PChar): Boolean; { True if P^ is a valid 8.3 DOS name }
  4370. type                                   { lowercase chars treated as invalid }
  4371.   TCharSet = Set of Char;
  4372. var
  4373.   DotCnt : Integer;
  4374.   CharCnt: Integer;
  4375.   C      : Char;
  4376.   Padder : Char;
  4377. begin { IsDosName }
  4378.   IsDosName := true;
  4379.   if not VFat
  4380.    then Exit;
  4381.   IsDosName := false;
  4382.   DotCnt := 0;
  4383.   CharCnt:= 8+1;                  { Maximum of 8 characters in the filename }
  4384.   if P^ = ' '
  4385.    then Exit;                     { Dos files names cannot start with space }
  4386.   while P^ <> #0 do
  4387.   begin
  4388.     C := P^;
  4389.     if (CharCnt = 0) or not (C in DosChars)
  4390.      then Exit;
  4391.     if P^ = '.' then
  4392.      if DotCnt = 0                { Dos filenames can only contain 1 "."    }
  4393.       then begin
  4394.              Inc(DotCnt);
  4395.              if (CharCnt = 9) or  { No null names or ending in a space char }
  4396.                 (PChar(Ptr(PtrRec(P).Seg, PtrRec(P).Ofs-1))^ = ' ')
  4397.               then Exit;
  4398.              CharCnt := 4;        { Maximum of .+3 characters for extension }
  4399.            end
  4400.       else Exit;                  { Only one '.' allowed in a file/dir name }
  4401.     Dec(CharCnt);
  4402.     Inc(P);
  4403.   end;
  4404.   Dec(P);
  4405.   IsDosName := P^ <> ' ';         { Dos file names cannot end with a space  }
  4406. end;
  4407.  
  4408. procedure ConvertNameCase(P: PChar); near;
  4409. begin
  4410.   if (P = nil) or (P^ = #0)
  4411.    then Exit;
  4412.   case FileCase of
  4413.     fnLowerCase:
  4414.       StrLower(P);
  4415.     fnUpperCase:
  4416.       StrUpper(P);
  4417.     else
  4418. {$ifdef LongNames}
  4419.       if IsDosName(P) then        { Must be fnDosLower or fnDos1stUpper     }
  4420. {$endif LongNames}
  4421.        begin
  4422.          if FileCase = fnDos1stUpper
  4423.           then Inc(P);
  4424.          StrLower(P);
  4425.        end;
  4426.   end;
  4427. end;
  4428.  
  4429. procedure ConvertPathCase(P: PChar; V: PVolumeInfo); near;
  4430. var
  4431.   N  : PChar;
  4432.   L,C: Word;
  4433. begin
  4434.   if (P = nil) or (P^ = #0) or (FileCase = fnPreserve) {$ifdef LongNames} or
  4435.      (V^.Attributes and vaCaseSensitive <> 0) {$endif LongNames} then Exit;
  4436.   C := 0;
  4437.   L := StrLen(P);
  4438.   N := P + L;
  4439.   while PtrRec(N).Ofs <> PtrRec(P).Ofs do
  4440.    begin
  4441.      Dec(N);
  4442.      if N^ = '\' then
  4443.       begin
  4444.         Inc(N);
  4445.         ConvertNameCase(N);
  4446.         Dec(N);
  4447.         N^ := #0;
  4448.         Inc(C);
  4449.       end;
  4450.    end;
  4451.   while C > 0 do
  4452.    begin
  4453.      if P^ = #0 then
  4454.       begin
  4455.         P^ := '\';
  4456.         Dec(C);
  4457.       end;
  4458.      Inc(P);
  4459.      Dec(L);
  4460.    end;
  4461. end;
  4462.  
  4463. { Standard Close Text (File or Device) - called by Close(F: Text) }
  4464.  
  4465. function TextClose(var T: Text): Integer; far;
  4466. var
  4467.   TR: TTextRec absolute T;
  4468. begin
  4469.   DosError := 0;
  4470.   if TR.Handle > 4                    { Don't close the standard devices    }
  4471.    then FileClose(TR.Handle);
  4472.   TR.Mode := fmClosed;
  4473.   TextClose := DosError;
  4474. end;
  4475.  
  4476. { Standard Read Text (File or Device) - called by Read/ReadLn(F: Text) }
  4477.  
  4478. function TextRead(var T: Text): Integer; far;
  4479. var
  4480.   TR: TTextRec absolute T;
  4481. begin
  4482.   TR.BufEnd := FileRead(TR.Handle, TR.BufPtr^, TR.BufSize);
  4483.   if DosError <> 0
  4484.    then TR.BufEnd := 0;
  4485.   TR.BufPos := 0;
  4486.   TextRead := DosError;
  4487. end;
  4488.  
  4489. { Standard Write to Text (TextFile) - called by Write/WriteLn(F: Text) }
  4490.  
  4491. function TextWriteFile(var T: Text): Integer; far;
  4492. var
  4493.   TR: TTextRec absolute T;
  4494. begin
  4495.   if FileWrite(TR.Handle, TR.BufPtr^, TR.BufPos) = TR.BufPos
  4496.    then TextWriteFile := DosError
  4497.    else TextWriteFile := 101;          { Write Error }
  4498.   TR.BufPos := 0;
  4499. end;
  4500.  
  4501. { Standard Write to Text (TextDevice) - called by Write/WriteLn(F: Text) }
  4502.  
  4503. function TextWriteDevice(var T: Text): Integer; far;
  4504. var
  4505.   TR: TTextRec absolute T;
  4506. begin
  4507.   FileWrite(TR.Handle, TR.BufPtr^, TR.BufPos);
  4508.   TR.BufPos := 0;
  4509.   TextWriteDevice := DosError;
  4510. end;
  4511.  
  4512. { Standard Open text - called by Reset/Rewrite/Append(var F:Text) }
  4513.  
  4514. function LfnOpenText(var TR: TTextRec): Integer; far;
  4515. var
  4516.   T       : Text absolute TR;
  4517.   Count   : Word;
  4518.   Inx     : Word;
  4519.   OpenMode: Word;
  4520.   Pos     : Longint;
  4521.   Regs    : TRegisters;
  4522. begin
  4523.   TR.Handle := TFileHandle(-1);
  4524.   InOutRes := 0;
  4525.   case TR.Mode of
  4526.     fmInput:
  4527.       begin
  4528.         OpenMode := stOpenRead;       { Open file for reading (Reset)       }
  4529.         TR.Handle := 0;
  4530.       end;                            { F.Handle = 0 (std i/p)              }
  4531.     fmOutput:
  4532.       begin
  4533.         OpenMode := stCreate;         { Open file for writing (Rewrite)     }
  4534.         TR.Handle := 1;
  4535.       end;
  4536.     fmInOut:
  4537.       begin
  4538.         OpenMode := stOpen;           { Open file for read/write access     }
  4539.         TR.Handle := 1;
  4540.       end;
  4541.     else
  4542.       begin
  4543.         LfnOpenText := deInvalidFunc;
  4544.         Exit;
  4545.       end;
  4546.   end;
  4547. {$ifdef LongNames}
  4548.   if TR.Name^ <> #0 then              { If not StdIn/StdOut then open file  }
  4549. {$else LongNames}
  4550.   if TR.Name[0] <> #0 then
  4551. {$endif LongNames}
  4552.    begin                              { Add file sharing flags of FileMode  }
  4553.      TR.Handle := FileOpenStr(TR.Name, OpenMode or (System.FileMode and $F0));
  4554.       if InOutRes <> 0 then
  4555.        begin
  4556.          TR.Mode := fmClosed;
  4557.          LfnOpenText := InOutRes;
  4558.          Exit;
  4559.        end;
  4560.    end;
  4561.  
  4562.   @TR.CloseFunc := @TextClose;
  4563.   @TR.InOutFunc := @TextRead;
  4564.   @TR.FlushFunc := nil;
  4565.  
  4566.   if TR.Mode <> fmInput then
  4567.    begin
  4568.      @TR.InOutFunc := @TextWriteDevice;
  4569.      @TR.FlushFunc := @TextWriteDevice;
  4570.      ClearRegs(Regs);
  4571.      Regs.BX := TR.Handle;
  4572.      Regs.AX := $4400;                { DOS - IOCTRL Get device information }
  4573.      MsDos(Regs);
  4574.      if Regs.DL and $80 = 0 then      { File, Not device                    }
  4575.       begin
  4576.         @TR.InOutFunc := @TextWriteFile;
  4577.         @TR.FlushFunc := @TextWriteFile;
  4578.         if TR.Mode = fmInOut then     { File Append                         }
  4579.          begin
  4580.            Pos := MaxLong(FileSeek(TR.Handle, -TR.Bufsize, skEnd), 0);
  4581.            Count := FileRead(TR.Handle, TR.BufPtr^, TR.BufSize);
  4582.            Inx := 0;
  4583.            while Count <> Inx do
  4584.              begin
  4585.                if TR.BufPtr^[Inx] = asEOF
  4586.                 then FileSeek(TR.Handle, Inx - Count, skEnd);
  4587.                Inc(Inx);
  4588.              end;
  4589.            TR.Mode := fmOutput;
  4590.            FileSeek(TR.Handle, Count - Inx, skEnd);
  4591.          end;
  4592.       end;
  4593.    end;
  4594.   LfnOpenText := InOutRes;
  4595. end;
  4596.  
  4597. {$ifndef TurboDos}
  4598.  
  4599. { Standard BlockWrite procedure }
  4600.  
  4601. procedure BlockWrite(var F: TFileRec; var Buf; Count: Word;
  4602.                      var Result: Word); far;
  4603. var
  4604.   R: Word;
  4605.   C: Longint;
  4606. begin
  4607.   R := 0;
  4608.   case F.Mode of
  4609.     fmClosed:
  4610.       InOutRes := 103;                          { File not not open         }
  4611.     fmInput:
  4612.        InOutRes := 105;                         { File not open for output  }
  4613.     fmOutput, fmInOut:
  4614.       InOutRes := 0;
  4615.     else
  4616.       InOutRes := 102;                          { File not assigned         }
  4617.   end;
  4618.   if InOutRes <> 0
  4619.    then Exit;
  4620.   C := LongMulW(Count, F.RecSize);
  4621.   if C <= MaxFileBlock
  4622.    then R := FileWrite(F.Handle, Buf, C) div F.RecSize
  4623.    else InOutRes := 215;                        { Arithmetic overflow error }
  4624.   if @Result <> nil
  4625.    then Result := R;
  4626.   if (InOutRes = 0) and (R <> Count)
  4627.    then InOutRes := 101;                        { Disk write error          }
  4628. end;
  4629.  
  4630. { Standard BlockRead procedure }
  4631.  
  4632. procedure BlockRead(var F: TFileRec; var Buf; Count: Word;
  4633.                     var Result: Word); far;
  4634. var
  4635.   R: Word;
  4636.   C: Longint;
  4637. begin
  4638.   R := 0;
  4639.   case F.Mode of
  4640.     fmClosed:
  4641.       InOutRes := 103;                          { File not not open         }
  4642.     fmOutPut:
  4643.        InOutRes := 104;                         { File not open for input   }
  4644.     fmInput, fmInOut:
  4645.       InOutRes := 0;
  4646.     else
  4647.       InOutRes := 102;                          { File not assigned         }
  4648.   end;
  4649.   if InOutRes <>  0
  4650.    then Exit;
  4651.   C := LongMulW(Count, F.RecSize);
  4652.   if C <= MaxFileBlock
  4653.    then R := FileRead(F.Handle, Buf, LongRec(C).Lo) div F.RecSize
  4654.    else InOutRes := 215;                        { Arithmetic overflow error }
  4655.   if @Result <> nil
  4656.    then Result := R;
  4657.   if (InOutRes = 0) and (R <> Count)
  4658.    then InOutRes := 100;                        { Disk read error           }
  4659. end;
  4660.  
  4661. { Standard typed file read }
  4662.  
  4663. procedure LfnFileRead(var F: TFileRec; var Buf); far; assembler;
  4664. asm
  4665.     db $66; push  [F].Word[0]                 { BlockRead(F, Buf, 1, nil);  }
  4666.     db $66; xor   ax,ax
  4667.     db $66; push  [Buf].Word[0]
  4668.             push  1
  4669.     db $66; push  ax
  4670.             push  cs
  4671.             call  near ptr BlockRead
  4672.             pop   bp                          { Must leave F on the stack!  }
  4673.             retf  4
  4674. end;
  4675.  
  4676. { Standard typed file write }
  4677.  
  4678. procedure LfnFileWrite(var F: TFileRec; var Buf); far; assembler;
  4679. asm
  4680.     db $66; push  [F].Word[0]                 { BlockWrite(F, Buf, 1, nil); }
  4681.     db $66; xor   ax,ax
  4682.     db $66; push  [Buf].Word[0]
  4683.             push  1
  4684.     db $66; push  ax
  4685.             push  cs
  4686.             call  near ptr BlockWrite
  4687.             pop   bp                          { Must leave F on the stack!  }
  4688.             retf  4
  4689. end;
  4690.  
  4691. { Standard Seek procedure }
  4692.  
  4693. procedure SeekFile(F: TFileRec; Pos: Longint); far;
  4694. begin
  4695.   case F.Mode of
  4696.     fmClosed:
  4697.       InOutRes := 103;                          { File not not open         }
  4698.     fmInput, fmOutPut, fmInOut:
  4699.       InOutRes := 0;
  4700.     else
  4701.       InOutRes := 102;                          { File not assigned         }
  4702.   end;
  4703.   FileSeek(F.Handle, Pos * F.RecSize, skStart);
  4704. end;
  4705.  
  4706. { Standard FilePos function }
  4707.  
  4708. function FilePos(var F: TFileRec): Longint;
  4709. begin
  4710.   case F.Mode of
  4711.     fmClosed:
  4712.       InOutRes := 103;                          { File not not open         }
  4713.     fmInput, fmOutPut, fmInOut:
  4714.       InOutRes := 0;
  4715.     else
  4716.       InOutRes := 102;                          { File not assigned         }
  4717.   end;
  4718.   if InOutRes <> 0
  4719.    then FilePos := -1
  4720.    else FilePos := FilePosition(F.Handle);
  4721. end;
  4722.  
  4723. {$endif !TurboDos}
  4724.  
  4725. { Close(F) - replacement System.Close(var F: File) procedure }
  4726.  
  4727. procedure LfnCloseFile(var F: TFileRec); far;
  4728. begin
  4729.   if (F.Mode > fmClosed) and (F.Mode <= fmInOut) then
  4730.    begin
  4731.      if F.Handle > 4
  4732.       then FileClose(F.Handle);
  4733.      F.Mode := fmClosed;
  4734.    end;
  4735. end;
  4736.  
  4737. { Called by System.Reset(var F:File) and System.Rewrite(var F: File) }
  4738.  
  4739. function LfnOpenFile(var F: TFileRec; RecSize: Word): Word; far;
  4740. var
  4741.   Mode : Word;
  4742.   InOut: Word;
  4743. begin
  4744.   asm
  4745.             mov   [Mode],ax            { AX = file open mode                }
  4746.             mov   [InOut],dx           { DX = Function (0=Reset, 1=Rewrite) }
  4747.   end;
  4748.   case F.Mode of                       { Check current status.              }
  4749.     fmInOut, fmOutPut, fmInput:        { If file open (any mode), then close}
  4750.       begin
  4751.         FileClose(F.Handle);
  4752.         F.Mode := fmClosed;
  4753.       end;
  4754.     fmClosed:
  4755.       ;
  4756.     else
  4757.       begin
  4758.         InOutRes := 102;               { File has not been assigned so error}
  4759.         Exit;
  4760.       end;
  4761.   end;
  4762.   F.Handle := InOut;                   { Handle = 0 (Std I/P or 1 (Std O/P) }
  4763. {$ifdef LongNames}
  4764.   if (F.Name <> nil) and (F.Name^ <> #0) then{ nul name means StdIn or StdOt}
  4765. {$else LongNames}
  4766.   if F.Name <> #0 then                       { nul name means StdIn or StdOt}
  4767. {$endif LongNames}
  4768.    begin
  4769.      F.Handle := FileOpenStr(F.Name, Mode);  { Try to open the file in the  }
  4770.      if DosError = 0 then                    { given mode.                  }
  4771.       begin
  4772.         F.Mode := fmInOut;
  4773.         F.RecSize := RecSize;
  4774.       end;
  4775.    end;
  4776. end;
  4777.  
  4778. { Erase(F) - replacement System.Erase(var F: File/var T: Text) procedure }
  4779.  
  4780. procedure LfnErase(var F: TFileRec); far;
  4781. begin
  4782.   case F.Mode of
  4783.     fmClosed:
  4784.       FileErase(F.Name);
  4785.     fmInput..fmInOut:
  4786.       InOutRes := 5;                   { File Access Denied                 }
  4787.     else
  4788.       InOutRes := 102;                 { File not assigned                  }
  4789.   end;
  4790. end;
  4791.  
  4792. procedure SystemFreeMem(P: Pointer; Size: Word); near;
  4793. begin
  4794.   FreeMem(P, Size);
  4795. end;
  4796.  
  4797. {$ifdef LongNames}
  4798.  
  4799. { Inputs: ES:DI @TFileRec that is being assigned or destroyed }
  4800.  
  4801. procedure UnAssignName; near; assembler;
  4802. asm
  4803.             cmp   [es:di].TFileRec.Mode,fmClosed { Make sure F has been     }
  4804.             jb    @@Exit                         { previously assigned.     }
  4805.             cmp   [es:di].TFileRec.Mode,fmInOut
  4806.             ja    @@Exit
  4807.             cmp   [es:di].TfileRec.NameLen,type TFileRec.NameBuf
  4808.             jbe   @@Exit                         { If the length of the name}
  4809.             mov   [es:di].TFileRec.Mode,0        { record is unasssigned    }
  4810.             pusha                                { is > SizeOf internal name}
  4811.             push  es                             { name buffer, its on heap }
  4812.     db $66; push  [es:di].TFileRec.Name.Word[0]
  4813.             push  [es:di].TfileRec.NameLen
  4814.             call  SystemFreeMem
  4815.             pop   es
  4816.             popa
  4817. @@Exit:
  4818. end;
  4819.  
  4820. {$endif LongNames}
  4821.  
  4822. { UnAssign(F) - unlinks File or Text variable from its external file/device }
  4823.  
  4824. procedure UnAssign(var F); assembler;
  4825. asm
  4826.             les   di,[F]
  4827.             mov   ax,[es:di].TFileRec.Mode
  4828.             cmp   ax,fmClosed
  4829.             jb    @@Done                        { File/Text not assigned    }
  4830.             cmp   ax,fmOutput
  4831.             jb    @@DoClose                     { Not open for writing      }
  4832.             cmp   ax,fmInOut
  4833.             ja    @@Done                        { File/Text not assigned    }
  4834.     db $66; cmp   [es:di].TTextRec.InOutFunc.Word[0],0
  4835.             je    @@DoClose
  4836.             push  es                            { Flush the Text file       }
  4837.             push  di
  4838.             call  [es:di].TTextRec.InOutFunc
  4839.  
  4840. @@DoClose:  les   di,[F]
  4841.             cmp   [es:di].TTextRec.Handle,4
  4842.             jbe   @@NoClose
  4843.     db $66; cmp   [es:di].TTextRec.CloseFunc.Word[0],0
  4844.             jne   @@CloseTxt
  4845. @@CloseFle: push  es                            { Use LfnCloseFile to close }
  4846.             push  di
  4847.             push  cs
  4848.             call  near ptr LfnCloseFile
  4849.             jmp   @@NoClose
  4850.  
  4851. @@CloseTxt: push  es                            { Use CloseFunc to close    }
  4852.             push  di                            { the Text/File             }
  4853.             call  [es:di].TTextRec.CloseFunc
  4854.             or    ax,ax                         { Was it sucessful?         }
  4855.             jne   @@Done
  4856. @@NoClose:  les   di,[F]                        { No, so don't unassign it  }
  4857.             mov   [es:di].TTextRec.Mode,fmClosed
  4858.  
  4859. @@UnAssign:
  4860. {$ifdef LongNames}
  4861.             call  UnAssignName                  { Unallocate long filename  }
  4862. {$else LongNames}                               { and mark it as unassigned }
  4863.             mov   [es:di].TFileRec.Mode,0       { Mark it as unassigned     }
  4864. {$endif LongNames}
  4865. @@Done:
  4866. end;
  4867.  
  4868. { Inputs: ES:DI = @TFileRec that is being assigned or destroyed }
  4869. {         DS:SI = @FileName argument                            }
  4870. {         DX    = Filename type (1 -> PChar  0 -> PString)      }
  4871.  
  4872. procedure AssignName; near; assembler;
  4873. var
  4874.   TempName: TPathName;
  4875.   Len     : Word;
  4876. asm
  4877.             add   di,Offset(TFileRec.Name) { ES:DI = @TFileRec.Name         }
  4878.             push  di
  4879.             push  es                   { Save pointer to TFileRec.Name      }
  4880.             cld
  4881.  
  4882.             push  ss
  4883.             pop   es
  4884.             lea   di,[TempName]        { ES:DI = @TempName                  }
  4885. {$ifdef Windows}
  4886.             push  es                   { Push arguments for AnsiToOem call  }
  4887.             push  di
  4888.             push  es
  4889.             push  di
  4890. {$endif Windows}
  4891.             push  es                   { Push argument to StrNew (@TempName)}
  4892.             push  di
  4893.             push  es                   { Push argument to StrLen (@TempName)}
  4894.             push  di
  4895.             push  es                   { Push arg to FileExpand(@TempName)  }
  4896.             push  di
  4897.             push  es                   { Push arg to FileExpand(@TempName)  }
  4898.             push  di
  4899.             mov   cx,type TempName     { CX = Max filename length           }
  4900.             or    dx,dx                { PChar or String argument?          }
  4901.             jne   @@2                  { PChar                              }
  4902.             lodsb                      { AL = AX = Filename String length   }
  4903. {           cmp   cx,ax               }{ Name too long?                     }
  4904. {           jbe   @@1                 }{ No                                 }
  4905.             mov   cx,ax                { Limit length to SizeOf(TempName)   }
  4906.             xor   bx,bx
  4907.             jcxz  @@3                  { Null name passed                   }
  4908. @@2:        lodsb                      { Get next filename character        }
  4909.             or    al,al                { Null Terminator?                   }
  4910.             je    @@3                  { Yes                                }
  4911.             stosb                      { Store character in TempName        }
  4912.             inc   bx
  4913.             loop  @@2                  { Until all characters copied        }
  4914. @@3:        xor   ax,ax                { Store null-terminator              }
  4915.             stosb
  4916.             or    bx,bx
  4917.             mov   ax,seg @Data
  4918.             mov   ds,ax
  4919.             jnz   @@4
  4920. {$ifdef Windows}
  4921.             add   sp,20                { Pop FileExpand, StrLen OemToAnsii  }
  4922. {$else  Windows}
  4923.             add   sp,12                { Pop FileExpand & StrLen arguments  }
  4924. {$endif Windows}
  4925.             jmp   @@NoAlloc
  4926.  
  4927. @@4:        push  fcDirectory + fcCasePreserve{ Filename doesn't have to    }
  4928.             push  cs                          { exist, but its path does.   }
  4929.             call  near ptr FileExpand  { Expand filename into fully-qualif'd}
  4930.             call  StrLen               { filename, get qualified length     }
  4931.             inc   ax                   { Include null terminator in length  }
  4932.             mov   [Len],ax
  4933. {$ifdef Windows}
  4934.             call  AnsiToOem            { Convert TempName to OEM string     }
  4935. {$endif Windows}
  4936.             mov   cx,[Len]                  { Check & store filename length }
  4937. {$ifdef LongNames}
  4938.             cmp   cx,type TFileRec.NameBuf  { Is Filename short enough to be}
  4939.             jbe   @@NoAlloc                 { stored in the TTextRec? (Yes) }
  4940.             call  StrNew               { Store filename on the heap         }
  4941.             cld
  4942.             pop   es                   { ES:DI = @FileRec.Name              }
  4943.             pop   di
  4944.             mov   cx,[Len]
  4945.             mov   [es:di+Offset(TFileRec.NameLen)-Offset(TFileRec.Name)],cx
  4946.             stosw                      { FileRec.Name = @HeapName           }
  4947.             mov   ax,dx
  4948.             stosw
  4949.             jmp   @@Exit
  4950. {$endif LongNames}
  4951.  
  4952. @@NoAlloc:  pop   si                   { DS:SI = @F.Name                    }
  4953.             pop   ds
  4954.             pop   es                   { ES:DI = @TempName                  }
  4955.             pop   di
  4956. {$ifdef LongNames}
  4957.             mov   ax,di                { F.Name = @F.NameBuf                }
  4958.             mov   [es:di+Offset(TFileRec.NameLen)-Offset(TFileRec.Name)],cx
  4959.             add   ax,type TFileRec.Name
  4960.             stosw
  4961.             mov   ax,es
  4962.             stosw
  4963. {$endif LongNames}
  4964.             rep   movsb                { Store filename in F.NameBuf        }
  4965. @@Exit:
  4966. end;
  4967.  
  4968. { Rename(F) replacement System.Rename(var F: File/var T: Text) procedure }
  4969.  
  4970. procedure LfnRename(var F: TFileRec; NewName: PChar); far; assembler;
  4971. var
  4972.   New: TPathName;
  4973. asm
  4974.             les   di,[F]
  4975.             mov   [InOutRes],102       { File not assigned                  }
  4976.             cmp   [es:di].TFileRec.Mode,fmInOut
  4977.             ja    @@Exit
  4978.             cmp   [es:di].TFileRec.Mode,fmClosed
  4979.             jb    @@Exit
  4980.             je    @@1
  4981.             mov   [DosError],deAccessDenied            { File access denied }
  4982.             jmp   @@Exit
  4983.  
  4984. @@1:        push  dx                   { Save PChar/PString flag            }
  4985.  
  4986. {$ifdef Longnames}
  4987.     db $66; push  [es:di].TFileRec.Name.Word[0]  { FileRename arguments     }
  4988. {$else Longnames}
  4989.             add   di,TFileRec.Name
  4990.             push  es
  4991.             push  di
  4992. {$endif Longnames}
  4993.             or    dx,dx                { PChar or String NewName?           }
  4994.     db $66; push  NewName.Word[0]      { Push PasToNull arguments if String }
  4995.             jnz   @@PChar1             { or FileRename arguments if PChar   }
  4996.             lea   di,New
  4997.             push  ss
  4998.             push  di
  4999.             call  PasToNull
  5000.             lea   di,New
  5001.             push  ss                   { Push FileRename arguments          }
  5002.             push  di
  5003.  
  5004. @@PChar1:   call  FileRename           { Try to rename the file             }
  5005.             cmp   [DosError],deNoError
  5006.             jne   @@Exit
  5007.             les   di,[F]
  5008. {$ifdef LongNames}
  5009.             call  UnAssignName         { Dispose of possibly old long name  }
  5010. {$endif LongNames}
  5011.             pop   dx                   { Get PChar/PString flag             }
  5012.             push  ds
  5013.             lds   si,[NewName]
  5014.             call  AssignName
  5015.             pop   ds
  5016. @@Exit:
  5017. end;
  5018.  
  5019. { Assign(F) - System.Assign(var F:File) standard procedure (String or PChar)}
  5020.  
  5021. procedure LfnAssignFile(var F: TFileRec; FileName: PChar); far; assembler;
  5022. asm                                    { SS:BX+8 = @TFileRec                }
  5023. {       XOR     DX,DX                  ; DX = 0 = String arg. DX = 1 = PChar}
  5024. {       MOV     BX,SP                  ; Why not use BP ?                   }
  5025.  
  5026.  { System code is hooked here }
  5027.                                        { ES:DI = @TFileRec                  }
  5028.             les   di,[F]
  5029.             push  ds
  5030.             push  dx
  5031.             cld
  5032.             xor   ax,ax
  5033.             stosw                      { F.Handle = 0                       }
  5034.             mov   ax,fmClosed
  5035.             stosw                      { F.Mode = fmClosed                  }
  5036.             xor   ax,ax
  5037.             mov   cx,(offset(TFileRec.Name)-offset(TFileRec.RecSize))/2
  5038.             rep   stosw                { Set all other TFileRec fields to 0 }
  5039.             pop   dx                        { DX = PChar/PString flag       }
  5040.             sub   di,offset(TFileRec.Name)  { ES:DI = @F                    }
  5041.             lds   si,[FileName]             { DS:SI = @FileName             }
  5042.             call  AssignName
  5043.             pop   ds
  5044. end;
  5045.  
  5046. { Assign(T) - System.Assign(var T:Text) standard procedure (String or PChar)}
  5047.  
  5048. procedure LfnAssignText(var T: TTextRec; FileName: PChar); far;
  5049. var
  5050.   F: TFileRec absolute T;
  5051. begin
  5052.   LfnAssignFile(F, Filename);
  5053.   @T.OpenFunc := @LfnOpenText;
  5054.   T.BufPtr := @T.Buffer;
  5055.   T.BufSize:= SizeOf(TTextBuf);
  5056. end;
  5057.  
  5058. {-------------------------- Miscellaneous functions ------------------------}
  5059.  
  5060. {$ifndef TurboDos}
  5061.  
  5062. procedure GetCBreak(var Break: Boolean);
  5063. var
  5064.   Regs: TRegisters;
  5065. begin
  5066.   ClearRegs(Regs);
  5067.   Regs.AX := $3300;
  5068.   MsDos(Regs);
  5069.   Break := Boolean(Regs.DL);
  5070. end;
  5071.  
  5072. procedure SetCBreak(Break: Boolean);
  5073. var
  5074.   Regs: TRegisters;
  5075. begin
  5076.   ClearRegs(Regs);
  5077.   Regs.AX := $3301;
  5078.   Regs.DL := Byte(Break);
  5079.   MsDos(Regs);
  5080. end;
  5081.  
  5082. {$endif !TurboDos}
  5083.  
  5084. type
  5085.   PFcb = ^TFcb;
  5086.   TFcb = record                        { DOS standard file control block    }
  5087.     Drive    : Byte;
  5088.     Name     : array[0..7] of Char;
  5089.     Ext      : array[0..2] of Char;
  5090.     BlockNum : Word;
  5091.     RecSize  : Word;
  5092.     FileSize : DWord;
  5093.     WriteDate: Word;
  5094.     WriteTime: Word;
  5095.     Reserved : array[0..7] of Byte;
  5096.     CurRecNum: Byte;
  5097.     RndRecNum: DWord;
  5098.   end;
  5099.  
  5100.   TPsp = array[0..127] of Byte;
  5101.  
  5102.   TExecParamBlock = record             { DOS "Exec" parameter block         }
  5103.     EnvSeg : Word;
  5104.     CmdTail: PString;
  5105.     FcB1   : PFcb;
  5106.     Fcb2   : PFcb;
  5107.     SS_SP  : DosPtr;
  5108.     CS_IP  : DosPtr;
  5109.   end;
  5110.  
  5111.   PExec = ^TExec;
  5112.   TExec = record                       { Structure of data stored in DosBuf }
  5113. {$ifdef DPMI}
  5114.     Prefix : TPsp;
  5115. {$endif DPMI}
  5116.     ExePath: TShortPath;
  5117.     Block  : TExecParamBlock;
  5118.     case integer of
  5119.       0: (CmdLine : TComStr;
  5120.           Fcb1    : TFcb;
  5121.           Fcb2    : TFcb);
  5122.       1: (LongPath: TPathName);
  5123.   end;
  5124.  
  5125. {.$ifdef TurboDos}
  5126.  
  5127. procedure Exec(const Path: String; const CmdLine: TComStr); assembler;
  5128. var
  5129.   ExecRec   : TExecParamBlock;
  5130.   FileBlock1: TFcb;
  5131.   FileBlock2: TFcb;
  5132.   PathBuf   : TShortPath;
  5133.   CmdLineBuf: TComStr;
  5134.   Regs      : TRegisters absolute CmdLineBuf;
  5135. const
  5136.   SaveSP    : Word = 0;                  { Use typed contants so they go in }
  5137.   SaveSS    : Word = 0;                  { the data segment, not on stack   }
  5138. asm
  5139.             lea   di,PathBuf       { PasToNull(FDosExpand(Path), @PathBuf); }
  5140.             push  ss                     { PasToNull String argument        }
  5141.             push  di
  5142.             push  ss                     { PasToNull PChar argument         }
  5143.             push  di
  5144.             push  ss                     { FDosExpand return String         }
  5145.             push  di
  5146.    db $66;  push  word ptr [Path]        { FDosExpand String argument       }
  5147.             push  cs
  5148.             call  near ptr FDosExpand
  5149.             call  PasToNull
  5150.  
  5151. {           mov   [SaveSP],sp  }         { MS-DOS 2.x trashes all regs, incl}
  5152. {           mov   [SaveSS],ss  }         { SS and SP, so save them in DS    }
  5153.             mov   ds,[PrefixSeg]         { ExecData.EnvSeg = @PrefixSeg     }
  5154.             mov   ax,word ptr ds:[$2C]
  5155.             mov   [ExecRec.EnvSeg],ax
  5156.  
  5157.             lds   si,[CmdLine]           { Convert command line to ASCIIZ   }
  5158.             lea   di,[CmdLineBuf]        { and store in CmdLine buffer      }
  5159.             lodsb
  5160.             cmp   al,126
  5161.             jb    @@2
  5162.             mov   al,126
  5163. @@2:        stosb                        { Store command line length byte   }
  5164.             cbw
  5165.             xchg  ax,cx
  5166.             rep      movsb
  5167.             mov   al,$0D                 { Store terminating carriage retrn }
  5168.             stosb
  5169.  
  5170.             push  ss
  5171.             lea   si,[CmdLineBuf]
  5172.             pop   ds
  5173.             mov   [ExecRec.CmdTail].Word[0],si { Store ptr to command line  }
  5174.             mov   [ExecRec.CmdTail].Word[2],ds
  5175.             inc   si                      { DS:SI = @CommandLine[1]         }
  5176.             lea   di,[FileBlock1]         { ExecData.Fcb1] = @FileBlock1    }
  5177.             mov   [ExecRec.Fcb1].Word[0],di
  5178.             mov   [ExecRec.Fcb1].Word[2],es
  5179.             mov   ax,$2901                { Parse 1st command arg into Fcb1^}
  5180.             int   intDos                  { Use exsisting Drive number in   }
  5181.             lea   di,[FileBlock2]           { FCB if none specified         }
  5182.             mov   [ExecRec.Fcb2].Word[0],di { ExecData.Fcb1] = @FileBlock1  }
  5183.             mov   [ExecRec.Fcb2].Word[2],es
  5184.             mov   ax,$2901                { Parse 2nd command arg into Fcb1^}
  5185.             int   intDos
  5186.             lea   dx,[PathBuf]
  5187.             lea   bx,[ExecRec]            { ES:DI = @ExecData               }
  5188.             mov   ax,$4B00                { DOS - Load and Execute          }
  5189.             int   intDos
  5190.             jc    @@3
  5191.             xor   ax,ax
  5192. @@3:        mov   dx,seg @Data            { Restore DS to global data seg   }
  5193.             cld
  5194.             mov   ds,dx
  5195. {           mov   ss,[SaveSS]  }          { Restore stack pointer           }
  5196. {           mov   sp,[SaveSP]  }
  5197.             mov   [DosError],ax
  5198. {$ifdef MsDos}
  5199.             push  dx
  5200.             mov   ah,$1A                  { MsDos - Set Disk Transfer Addr  }
  5201.             lds   dx,[DosBuf.RealBuf]     { DTA = DosBuf.RealBuf            }
  5202.             int   intDos
  5203.             pop   ds
  5204. {$else MsDos}
  5205.             push  ss
  5206.             lea   di,Regs
  5207.             pop   es
  5208.             mov   cx,type TRegisters / 2
  5209.             xor   ax,ax
  5210.             rep   stosw
  5211.             sub   di,type TRegisters
  5212.             mov   ax,[DosBuf.RealSeg]
  5213.             mov   es:[di].TRegisters.&AH,$1A
  5214.             mov   es:[di].TRegisters.&DS,ax
  5215.             mov   bx,intDos
  5216.             mov   ax,dpmiCallRealInt
  5217.             int   intDPMI
  5218. {$endif MsDos}
  5219. end;
  5220.  
  5221. (*
  5222. {$else TurboDos}
  5223.  
  5224. { The following Pascal code works, except when the DOS - Exec interrupt is  }
  5225. { called it reports error 8 - Memory Control Block Destroyed. I suspect this}
  5226. { is because the created Psp has not been allocated by DOS ?                }
  5227.  
  5228. procedure Exec(const Path: String; const CmdLine: TComStr);
  5229. var
  5230.   Regs   : TRegisters;
  5231.   CmdLen : Word;
  5232.   Buf    : TDosBuf;
  5233.   ExecRec: PExec absolute Buf;
  5234. begin
  5235.   if not GetDosMem(Buf, SizeOf(TExec)) then
  5236.    begin
  5237.      DosError := deNotEnoughMem;
  5238.      Exit;
  5239.    end;
  5240.   ClearRegs(Regs);
  5241.   Regs.ES := Buf.RealSeg;                 { ES:DI @ShortPath (ExePath)      }
  5242.   Regs.DS := Regs.ES;                     { DS:DX @LongPath                 }
  5243.  
  5244. {$ifdef LongNames}
  5245.   if VFat
  5246.    then begin                             { Exec does not support LFN's, so }
  5247.           Regs.SI := Ofs(ExecRec^.LongPath); { convert long path and put in }
  5248.           StrPLCopy(@ExecRec^.LongPath, Path, Buf.Size);           { DosBuf }
  5249.           Regs.DI := Ofs(ExecRec^.ExePath);            { ES:DI = @ShortName }
  5250.           Regs.CX := $8001;               { Get short path, use subst drive }
  5251.           Regs.AX := $7160;               { LFN - Get short filename        }
  5252.           DosError := MsDos(Regs);        { we must convert the EXE filename}
  5253.           if Regs.Flags and fCarry <> 0   { to its short path equivalent.   }
  5254.            then Exit;
  5255.         end
  5256.    else
  5257. {$endif LongNames}
  5258.         StrPLCopy(@ExecRec^.ExePath, Path, High(TPathStr));{ Put path in Buf.Path }
  5259.  
  5260.   CmdLen := Min(Length(CmdLine), 126);         { Cmdline -> DosBuf }
  5261.   Move(CmdLine[1], ExecRec^.CmdLine[1], CmdLen);
  5262.   ExecRec^.CmdLine[0] := Char(CmdLen);
  5263.   ExecRec^.CmdLine[CmdLen+1] := #13;
  5264.  
  5265.   PtrRec(ExecRec^.Block.CmdTail).Seg := Regs.DS;
  5266.   PtrRec(ExecRec^.Block.Fcb1).Seg := Regs.DS;
  5267.   PtrRec(ExecRec^.Block.Fcb2).Seg := Regs.DS;
  5268.  
  5269.   PtrRec(ExecRec^.Block.CmdTail).Ofs := Offset(@ExecRec^.CmdLine);
  5270.   PtrRec(ExecRec^.Block.Fcb1).Ofs := Offset(@ExecRec^.Fcb1);
  5271.   PtrRec(ExecRec^.Block.Fcb2).Ofs := Offset(@ExecRec^.Fcb2);
  5272.  
  5273. {$ifdef DPMI}
  5274.   Move(Ptr(PWord(Ptr(PrefixSeg, $002C))^, 0)^, ExecRec^.Prefix, SizeOf(TPsp));
  5275.   ExecRec^.Block.EnvSeg := 0 {Regs.DS};
  5276. {$else DPMI}
  5277.   ExecRec^.Block.EnvSeg := PWord(Ptr(PrefixSeg, $002C))^;
  5278. {$endif DPMI}
  5279.  
  5280.   Regs.SI := Offset(@ExecRec^.CmdLine[1]);{ DS:SI = @CommandLine[1]         }
  5281.   Regs.DI := Offset(@ExecRec^.Fcb1);      { ES:DI = @Fcb1                   }
  5282.   Regs.AX := $2901;                       { DOS - Parse Filname into FCB    }
  5283.   DosError := MsDos(Regs);
  5284.   if Regs.Flags and fCarry <> 0
  5285.    then Exit;
  5286.   Regs.AX := $2901;                       { DOS - Parse Filname into FCB    }
  5287.   Regs.DI := Offset(@ExecRec^.Fcb2);      { ES:DI = @Fcb2                   }
  5288.   DosError := MsDos(Regs);
  5289.   if Regs.Flags and fCarry <> 0
  5290.    then Exit;
  5291.  
  5292.   Regs.DX := Offset(@ExecRec^.ExePath);   { DS:DX = @ExecPath               }
  5293.   Regs.BX := Offset(@ExecRec^.Block);     { ES:BX = @ExecParameterBlock     }
  5294.   Regs.AX := $4B00;                       { DOS - Load and Execute          }
  5295.   DosError := MsDos(Regs);
  5296.   if Regs.Flags and fCarry = 0
  5297.    then DosError := 0;
  5298.   FreeDosMem(Buf);
  5299. end;
  5300. {$endif TurboDos}
  5301. *)
  5302.  
  5303. function DosExitCode: Word;
  5304. {$ifdef TurboDos} assembler;
  5305. asm
  5306.             mov   ah,$4D
  5307.             int   intDos
  5308. end;
  5309. {$else TurboDos}
  5310. var
  5311.   Regs: TRegisters;
  5312. begin
  5313.   ClearRegs(Regs);
  5314.   Regs.AH := $4D;
  5315.   DosExitCode := MsDos(Regs);
  5316. end;
  5317. {$endif TurboDos}
  5318.  
  5319. procedure Keep(ExitCode: Byte); assembler;
  5320. asm
  5321.             mov   es,[PrefixSeg]
  5322.             mov   ax,es
  5323.             mov   dx,word ptr [es:$0002]
  5324.             sub   dx,ax
  5325.             mov   al,[ExitCode]
  5326.             mov   ah,$31
  5327.             int   intDos
  5328. end;
  5329.  
  5330. function GetLocalName: TMachineName;
  5331. {$ifdef TurboDos}
  5332.                                        assembler;
  5333. asm
  5334.             push  ds
  5335.             lds   di,[@Result]
  5336.             xor   ax,ax
  5337.             mov   dx,di
  5338.             mov   [di],ax
  5339.             inc   dx                       { DS:DX @Result[1]               }
  5340.             mov   ax,$5E00;                { DOS Network - Get Machine name }
  5341.             int   intDos
  5342.             mov   bx,ax
  5343.             jc    @@Exit
  5344.             cmp   ch,0
  5345.             je    @@Exit
  5346.             mov   cx,high(TMachineName)
  5347.             add   di,cx
  5348.             mov   al,' '
  5349. @@1:        cmp   al,[di]
  5350.             jne   @@2
  5351.             dec   di
  5352.             loop  @@1
  5353. @@2:        sub   di,cx
  5354.             mov   [di],cl
  5355.             xor   bx,bx
  5356. @@Exit:     pop   ds
  5357.             mov   [DosError],bx
  5358. end;
  5359. {$else TurboDos}
  5360. var
  5361.   Name   : PMachineName absolute DosBuf;
  5362.   Regs   : TRegisters;
  5363.   SaveBuf: TMachineName;
  5364.   Result : TMachineName;
  5365.   j      : Word;
  5366. begin
  5367.   Result := '';
  5368.   CheckDosBuf(SaveBuf, SizeOf(SaveBuf));
  5369.   ClearRegs(Regs);
  5370.   Regs.DS := DosBuf.RealSeg;
  5371.   Regs.AH := $5E;                          { DOS Network - Get Machine name }
  5372.   DosError:= MsDos(Regs);
  5373.   if (Regs.Flags and fCarry = 0) and (Regs.CH <> 0) then
  5374.    begin
  5375.      DosError := deNoError;
  5376.      Move(Name^, Result[1], High(TMachineName));
  5377.      j := High(TMachineName);
  5378.      while Result[j] = ' ' do              { Remove trailing padding spaces }
  5379.       Dec(j);
  5380.      Result[0] := Chr(j);
  5381.    end;
  5382.   RestoreDosBuf(SaveBuf, SizeOf(SaveBuf));
  5383.   GetLocalName := Result;
  5384. end;
  5385. {$endif TurboDos}
  5386.  
  5387. procedure GetTempFileStr(TempName: PChar; AutoErase: Boolean);
  5388. var
  5389.   Temp: PPathStr absolute TempName;
  5390. begin
  5391.   Temp^ := NullToPas(TempName);
  5392.   GetTempFile(Temp^, AutoErase);
  5393.   PasToNull(Temp^, TempName);
  5394. end;
  5395.  
  5396. procedure GetTempFile(var TempName: TPathStr; AutoErase: Boolean);
  5397. var
  5398.   Suffix: String[3];
  5399.   j     : Byte;
  5400.   SR    : TSearchRec;
  5401.   Temp  : TDirStr;
  5402. begin
  5403.   { Get temp directory name from environment TMP or TEMP variable or use  }
  5404.   { the application's directory if there's no valid TMP or TEMP directory }
  5405.  
  5406.   if TempDir = nil then
  5407.    begin
  5408.      Temp := GetEnv('TEMP');
  5409.      if (Temp = '')
  5410.       then Temp := GetEnv('TMP');
  5411. {$V-}AddDirSep(Temp); {$V+}           { Append backslash if not in variable }
  5412.      if Temp = '\'                    { Verify the existance of the temp dir}
  5413.       then Temp := ExeDir
  5414.       else begin
  5415.              Temp := FExpand(Temp, fcCasePreserve + fcFileName);
  5416.              AddDirSep(Temp);
  5417.              if DosError <> deNoError
  5418.               then Temp := ExeDir;
  5419.            end;
  5420.      TempDir := PDirStr(NewStr(Temp));
  5421.    end;
  5422.  
  5423.   { Keep generating file names until we find one that's not in use }
  5424.  
  5425.   TempNameCnt := 0;
  5426.  
  5427.   while true do
  5428.    begin                                      { Append a suitable file name }
  5429.      repeat
  5430.        if not (TempNameCnt in TempNums)
  5431.         then Break;
  5432.        Inc(TempNameCnt);                            { Advance counter       }
  5433.      until TempNameCnt = 256;
  5434.  
  5435.      if TempNameCnt = 256 then
  5436.       begin
  5437.         TempName := '';
  5438.         DosError := deFileExists;
  5439.         Exit;
  5440.       end;
  5441.  
  5442.      Str(TempNameCnt, Suffix);                      { Create numeric suffix }
  5443.      for j := Length(Suffix)+1 to High(Suffix) do
  5444.       Suffix := '0' + Suffix;
  5445.  
  5446.      TempName := FExpand(TempDir^ + TempPrefix + Suffix + '.TMP',
  5447.                          fcCasePreserve + fcFileName);
  5448.  
  5449.      { See if file name is already in use }
  5450.  
  5451.      if (DosError = deFileNotFound) or (DosError = dePathNotFound)
  5452.       then Break;
  5453.      Inc(TempNameCnt);                              { Current number is in  }
  5454.    end;                                             { use, so incriment it. }
  5455.   if AutoErase
  5456.    then Include(TempNums, TempNameCnt);
  5457.   DosError := deNoError;
  5458. end;
  5459.  
  5460. procedure EraseTempFile(const TempName: TPathStr);
  5461. var
  5462.   J,E: Integer;
  5463. begin
  5464.   FErase(TempName);
  5465.   Val(Copy(TempName, Pos('.', TempName)-3, 3), J,E);
  5466.   if E = 0
  5467.    then Exclude(TempNums, J);
  5468. end;
  5469.  
  5470. procedure EraseTempFileStr(TempName: PChar);
  5471. var
  5472.   Temp: PString absolute TempName;
  5473. begin
  5474.   Temp^ := NullToPas(TempName);
  5475.   EraseTempFile(Temp^);
  5476.   PasToNull(Temp^, TempName);
  5477. end;
  5478.  
  5479. {-------------------------- Additional Drive functions ---------------------}
  5480.  
  5481. function PathValid(Path: PChar): Boolean;
  5482. begin
  5483. end;
  5484.  
  5485. type
  5486.   PValidRec = ^TValidRec;
  5487.   TValidRec = record
  5488.     Name: array[0..79] of Char;
  5489.     Fcb : array[0..36] of Byte;
  5490.   end;
  5491.  
  5492. function DosPathValid(const Path: TPathStr): Boolean; assembler;
  5493. var
  5494.   Rec: PValidRec absolute DosBuf;
  5495. {$ifdef DPMI}
  5496. var
  5497.   Regs: TRegisters;
  5498. {$endif DPMI}
  5499. asm
  5500.             push  ds                   { Convert Pascal-style string to a   }
  5501.             les   di,[DosBuf.Buf]      { (ES:DI = @Rec.Name)                }
  5502.             xor   cx,cx                { null-terminated string.            }
  5503.             cmp   [DosBuf.Size],type TValidRec
  5504.             lds   si,[Path]
  5505.             jae   @@1
  5506.             mov   al,0
  5507.             pop   ds
  5508.             jmp   @@Exit
  5509.  
  5510. @@1:        cld
  5511.             mov   cl,[si]
  5512.             inc   si
  5513.             rep   movsb
  5514.             mov   [es:di],cl
  5515. {$ifdef MSDOS}
  5516.             mov   ax,es
  5517.             mov   si,cx                { DS:SI = @Rec.Name                  }
  5518.             mov   ds,ax
  5519.             mov   di,TValidRec.Fcb     { ES:DI = @Rec.Fcb                   }
  5520.             mov   ax,$2906;            { DOS function 29h = Parse Filename  }
  5521.             int   intDos
  5522.             pop   ds
  5523. {$else MSDOS}
  5524.             pop   ds
  5525.             mov   dx,[DosBuf.RealSeg]
  5526.             push  ss
  5527.             lea   di,Regs
  5528.             pop   es                        { ES:DI = @RealRegs             }
  5529.             cld
  5530.             mov   cx,type TRegisters / 2
  5531.             xor   ax,ax
  5532.             rep   stosw
  5533.             mov   [Regs.&DS],dx             { Regs.DS:SI = @Rec.Name        }
  5534.             lea   di,Regs                   { ES:DI = @Regs                 }
  5535.             mov   [Regs.&ES],dx
  5536.             mov   ax,dpmiCallRealInt        { Call real-mode interrupt      }
  5537.             mov   [Regs.&AX],$2906;         { DOS Fn 2906h = Parse Filename }
  5538.             mov   bx,intDos                 { BL = interrupt number ($21)   }
  5539.             mov   [Regs.&DI],TValidRec.Fcb  { Regs.ES:DI = @Rec.Fcb         }
  5540.             int   intDPMI                   { CX already equals 0           }
  5541.             mov   ax,[Regs.&AX]
  5542. {$endif MSDOS}
  5543.             inc   al
  5544.             jz    @@Exit                    { if Regs.al <> $FF             }
  5545.             mov   al,1                      { then Path is valid            }
  5546. @@Exit:
  5547. end;
  5548.  
  5549. function GetDrives: String;                 { Return list of valid system   }
  5550. var                                         { drives. eg: a return string of}
  5551.   Drv : Char;                               { 'ACD' means drives A:, C: and }
  5552.   Pad : Char;                               { D: are valid on this machine. }
  5553.   Regs: TRegisters;
  5554. begin
  5555.   if DriveList = '' then
  5556.    begin
  5557.      for Drv := 'A' to 'Z' do
  5558.       if DosPathValid(Drv + ':')
  5559.        then DriveList := DriveList + Drv;
  5560.      if Pos('AB', DriveList) <> 0 then      { Check for single floppy       }
  5561.       begin
  5562.         ClearRegs(Regs);
  5563.         Regs.AX := $440E;                   { IOCTL - Get logical device map}
  5564.         Regs.BL := 1;                       {         for Drive A:          }
  5565.         if (Lo(MsDos(Regs)) <> 0) then
  5566.          begin
  5567.            if Regs.AL <> 1 then
  5568.             begin
  5569.               Regs.AX := $440F;             { IOCTL - Set logical device map}
  5570.               Regs.BL := 1;
  5571.               MsDos(Regs);
  5572.             end;
  5573.            Delete(DriveList, 2, 1);         { Remove Drive B from list      }
  5574.          end;
  5575.       end;
  5576.    end;
  5577.   GetDrives := DriveList;
  5578. end;
  5579.  
  5580. function DriveValid(Drive: Char): Boolean;
  5581. begin
  5582.   DriveValid := Pos(DosUpCase(Drive), GetDrives) <> 0;
  5583. end;
  5584.  
  5585. function DriveRemove(Drive: Char): Boolean;
  5586. var
  5587.   V: PVolumeInfo;
  5588. begin
  5589.   V := GetVolumeInfo(UpCase(Drive));
  5590.   DriveRemove := (V <> nil) and (V^.Attributes and vaIsRemoveable <> 0);
  5591. end;
  5592.  
  5593. function GetDriveInfo(Drive: Char; var Info: TBlockDevInfo): Byte;
  5594. {$ifdef DPMI}
  5595. var
  5596.   Regs   : TRegisters;
  5597.   SaveBuf: TBlockDevInfo;
  5598.   DevInfo: PBlockDevInfo absolute DosBuf;
  5599. begin
  5600.   GetDriveInfo := dtError;
  5601.   Drive := DosUpCase(Drive);
  5602.   CheckDosBuf(SaveBuf, SizeOf(SaveBuf));    { Save contents of DosBuf       }
  5603.   DevInfo^.SpecialFunc := 1;                { Use exsisting BPB             }
  5604.   ClearRegs(Regs);
  5605.   Regs.AX := $440D;                         { IOCTL       Generic block I/O }
  5606.   Regs.CX := $0860;                         { Disk drive: Get device params }
  5607.   Regs.BL := Byte(Drive) - (Byte('A')-1);   { BL contains drive number      }
  5608.   Regs.DS := DosBuf.RealSeg;
  5609.   MsDos(Regs);
  5610.   if Regs.Flags and fCarry = 0
  5611.    then GetDriveInfo := DevInfo^.DeviceType
  5612.    else GetDriveInfo := dtError;
  5613.   Move(DevInfo^, Info, SizeOf(Info));
  5614.   RestoreDosBuf(SaveBuf, SizeOf(SaveBuf));  { Restore contents of DosBuf    }
  5615. {$else DPMI} assembler;
  5616. asm
  5617.             push    ds
  5618.             mov     dl,[Drive]
  5619.             and     dl,01011111b            { Convert Drive letter to upper }
  5620.             cmp     dl,'A'                  { case and Check if in range    }
  5621.             jb      @@BadExit
  5622.             cmp     dl,'Z'
  5623.             ja      @@BadExit
  5624.             and     dl,00011111b            { Convert to drive number       }
  5625.  
  5626.             lds     bx,[Info]               { Index Block Device info block }
  5627.             mov     ax,$440D                { IOCTL: Generic block I/O      }
  5628.             mov     cx,$0860                { Disk drive: Get device params }
  5629.             mov     byte ptr [ds:bx],1      { Use exsisting BPB             }
  5630.             xchg    dx,bx                   { DS:DX indexes the param block }
  5631.             int     21h                     { BL contains drive number      }
  5632.             mov     bx,dx
  5633.             mov     al,[ds:bx+TBlockDevInfo.DeviceType]
  5634.             jnc     @@Exit
  5635. @@BadExit:  mov     al,-1                   { -1 indicates a bad call       }
  5636. @@Exit:     pop     ds                      { Otherwise function returns the}
  5637. {$endif DPMI}                               { device type                   }
  5638. end;
  5639.  
  5640. function IsCdRom(Drive: Char): WordBool; assembler;
  5641. {$ifdef DPMI}                               { Check to see if it's a CD-ROM }
  5642. var
  5643.   Regs: TRegisters;
  5644. asm
  5645.             push  ss
  5646.             xor   ax,ax
  5647.             pop   es
  5648.             mov   cx,type TRegisters / 2    { FillChar(Regs,SizeOf(Regs), 0)}
  5649.             lea   di,Regs
  5650.             cld
  5651.             rep   stosw
  5652.             mov   cl,[Drive]
  5653.             mov   [Regs.&AX],$150B
  5654.             sub   cl,'A'                    { "A:" = 0, "B:" = 1 etc        }
  5655.             sub   di,type TRegisters        { ES:DI = @RealRegs             }
  5656.             mov   [Regs.&CX],cx             { CX = Drive number             }
  5657.             xor   cx,cx                     { Use stack provided by DPMI    }
  5658.             mov   ax,dpmiCallRealInt        { Call real-mode interrupt      }
  5659.             mov   bx,$002F                  { $2F (DOS Multiplex interrupt) }
  5660.             int   intDPMI
  5661.             mov   ax,0
  5662.             jc    @@NotCD                   { DPMI function failed          }
  5663.             cmp   [Regs.&BX],$ADAD          { Verification ID               }
  5664.             jne   @@NotCD
  5665.             mov   ax,[Regs.&AX]             { Non-zero means Drive is a CD  }
  5666. {$else DPMI}
  5667.   asm
  5668.             mov   cl,[Drive]
  5669.             mov   ax,$150B
  5670.             mov   ch,0
  5671.             push  bp
  5672.             sub   cl,'A'
  5673.             push  ds
  5674.             int   $2F
  5675.             pop   ds
  5676.             pop   bp
  5677.             xor   dx,dx
  5678.             cmp   bx,$ADAD
  5679.             xchg  dx,ax
  5680.             jne   @@NotCD
  5681.             mov   ax,dx                     { Non-zero means Drive is a CD  }
  5682. {$endif DPMI}
  5683.    @@NotCD:
  5684. end;
  5685.  
  5686. function GetFloppyType(Drive: Char): Byte; assembler;
  5687. {$ifdef DPMI}
  5688. var
  5689.   Regs: TRegisters;
  5690. asm
  5691.             push  ss
  5692.             xor   ax,ax
  5693.             pop   es
  5694.             mov   cx,type TRegisters / 2
  5695.             lea   di,Regs
  5696.             cld
  5697.             mov   dl,[Drive]
  5698.             rep   stosw
  5699.             and   dl,01011111b              { Convert Drive letter to upper }
  5700.             mov   [Regs.&AH],$08
  5701.             sub   dl,'A'
  5702.             lea   di,Regs                   { ES:DI = @Regs                 }
  5703.             mov   [Regs.&DL],dl             { DL = Drive number             }
  5704.             mov   ax,dpmiCallRealInt        { Simulate real-mode interrupt  }
  5705.             mov   bx,$13                    { $13 (BIOS Drives)             }
  5706.             int   intDPMI
  5707.             mov   ah,[Regs.&AH]             { AH <> 0 means error           }
  5708.             mov   bl,[Regs.&BL]             { 1 = 360, 2 = 1200, 3 = 720    }
  5709. {$else DPMI}
  5710. asm
  5711.             mov   dl,[Drive]
  5712.             mov   ah,$08
  5713.             and   dl,01011111b              { Convert Drive letter to upper }
  5714.             sub   dl,'A'                    { A: = 0                        }
  5715.             int   $13
  5716. {$endif DPMI}                               { 4 = 1440                      }
  5717.             cmp  ah,0
  5718.             je   @@1                        { AH <> 0 means error           }
  5719.             mov  bl,0
  5720. @@1:        mov  al,bl
  5721. end;
  5722.  
  5723. function GetChangeLineType(Drive: Char): Byte; assembler;
  5724. {$ifdef DPMI}
  5725. var
  5726.   Regs: TRegisters;
  5727. asm
  5728.             push  ss
  5729.             xor   ax,ax
  5730.             pop   es
  5731.             mov   cx,type TRegisters / 2
  5732.             lea   di,Regs
  5733.             cld
  5734.             mov   dl,[Drive]
  5735.             rep   stosw                     { CX=0 = Use stack provided by  }
  5736.             and   dl,01011111b              { Convert Drive letter to upper }
  5737.             mov   [Regs.&AX],$1500          { the DPMI server               }
  5738.             sub   dl,'A'
  5739.             sub   di,type TRegisters        { ES:DI = @RealRegs             }
  5740.             mov   [Regs.&DL],dl             { DL = Drive number             }
  5741.             mov   ax,dpmiCallRealInt        { Simulate real-mode interrupt  }
  5742.             mov   bx,$13                    { $13 (BIOS Drives)             }
  5743.             int   intDPMI
  5744.             shr   [Regs.&Flags],1           { 0= NoDrive      1= Floppy w/o }
  5745.             mov   al,[Regs.&AH]             { 2= Floppy with  3= HardDisk   }
  5746. {$else DPMI}
  5747. asm
  5748.             mov   dl,[Drive]
  5749.             mov   ah,$15
  5750.             and   dl,01011111b              { Convert Drive letter to upper }
  5751.             sub   dl,'A'
  5752.             int   13h
  5753.             mov   al,ah
  5754. {$endif DPMI}
  5755.             jnc   @@Exit                    { Call is valid AL contains type}
  5756.             mov   al,4
  5757.  @@Exit:
  5758. end;
  5759.  
  5760. function GetDriveType(Drive: Char;
  5761.                       var IsRemoveable, HasChangeLine: Boolean): Byte;
  5762. var
  5763.   V: PVolumeInfo;
  5764. begin
  5765.   V := GetVolumeInfo(Drive);
  5766.   IsRemoveable := V^.Attributes and vaIsRemoveable <> 0;
  5767.   HasChangeLine:= V^.Attributes and vaHasChangeLine <> 0;
  5768.   GetDriveType := V^.DriveType;
  5769. end;
  5770.  
  5771. { Validate and return drive type given a drive letter }
  5772.  
  5773. type
  5774.   PDosDPB = ^TDosDPB;
  5775.   TDosDPB = record                { 21 32-- DOS Drive Parameter Block:      }
  5776.     DriveNum            : Byte;   { drive number (00h = A:, 01h = B:, etc)  }
  5777.     UnitNum             : Byte;   { unit number within device driver        }
  5778.     BytesPerSector      : Word;   { bytes per sector                        }
  5779.     HighestSectInCluster: Byte;   { highest sector number within a cluster  }
  5780.     ClustToSectShiftCnt : Byte;   { shift count for clusters into sectors   }
  5781.     ReservedSectors     : Word;   { No. of reserved sectors at strt of drive}
  5782.     NumOfFats           : Byte;   { number of FATs                          }
  5783.     NumOfRootEntries    : Word;   { number of root directory entries        }
  5784.     FistUserDataSector  : Word;   { number of 1st sector containg user data }
  5785.     HighestClusterNum   : Word;   { highest cluster number (data clusters+1)}
  5786.                                   { 16-bit FAT if > 0FF6h, else 12-bit FAT  }
  5787.     SectorsPerFat       : Byte;   { number of sectors per FAT               }
  5788.     FirstDirSector      : Word;   { sector number of first directory sector }
  5789.     DeviceDriverHeader  : DosPtr; { address of device driver header         }
  5790.     MediaID             : Byte;   { media ID byte (see #0655)               }
  5791.     DiskAccessed        : Byte;   { 00h if disk accessed, FFh if not        }
  5792.     NextDPB             : DosPtr; { pointer to next DPB                     }
  5793.   end;
  5794.  
  5795. function GetStdDriveType(Drive: Char;
  5796.                          var IsRemoveable, HasChangeLine: Boolean): Byte;
  5797. var
  5798.   CLT    : Byte;
  5799.   DevType: Byte;
  5800.   Info   : TBlockDevInfo;
  5801.   DPB    : PDosDPB;
  5802.   Regs   : TRegisters;
  5803. const
  5804.   FloppyTbl: array[0..6] of Byte = (
  5805.     dtUnKnown, dtFloppy360, dtFloppy1200, dtFloppy720, dtFloppy1440,
  5806.     dtFloppy2880, dtUnKnown);
  5807. begin
  5808.   GetStdDriveType := dtError;
  5809.   IsRemoveable := false;
  5810.   HasChangeLine:= false;
  5811.  
  5812.   Drive := DosUpCase(Drive);
  5813.   if (Drive < 'A') or (Drive > 'Z')
  5814.    then Exit;
  5815.  
  5816.   { First see if it's a floppy with or without a change-line }
  5817.  
  5818.   CLT := GetChangeLineType(Drive);   { "Floppy" probably means any drive    }
  5819.   case CLT of                        { with removable media.                }
  5820.  
  5821.     { 0 is supposed to indicate an invalid drive, but some BIOS's report  }
  5822.     { fixed drives as invalid too, so GetChangeLineType cannot be used to }
  5823.     { weed out drive B: on a single floppy drive system.                  }
  5824.  
  5825. (*
  5826.     0:                               { CLT = 0 => drive not valid. This     }
  5827.       Exit;                          { weeds out B: on a single floppy sys. }
  5828. *)
  5829.     1,2:
  5830.       begin                          { Floppy with and w/o changeline       }
  5831.         IsRemoveable := true;        { Drive media is removable.            }
  5832.         HasChangeLine := CLT = 2;    { Device supports changeline if CLT =2 }
  5833.         if IsCDRom(Drive)
  5834.          then GetStdDriveType := dtCDRom
  5835.          else GetStdDriveType := FloppyTbl[Min(GetFloppyType(Drive),
  5836.                                                High(FloppyTbl))];
  5837.       end
  5838.     else                             { CLT is not 1 or 2                    }
  5839.       begin
  5840.         DevType := GetDriveInfo(Drive, Info);
  5841.         if DevType >= dtUnknown
  5842.          then if IsCDRom(Drive)           { Not a standard DOS block device }
  5843.                then begin                 { It's a CD-ROM drive             }
  5844.                       GetStdDriveType := dtCDRom;
  5845.                       IsRemoveable := true;
  5846.                     end
  5847.                else begin
  5848.                       if DevType = dtError then
  5849.                        begin
  5850.                          DevType := dtFixedDisk;
  5851.                          ClearRegs(Regs);
  5852.                          Regs.AH := $32;
  5853.                          Regs.DL := Ord(Drive) - Ord('A') + 1;
  5854.                          MsDos(Regs);
  5855.                          if Regs.AL = 0 then
  5856.                           begin
  5857.                             DPB := MapDosPtr(Ptr(Regs.DS, Regs.BX));
  5858.                             if (DPB^.NumOfFATs = 1) and (DPB^.UnitNum = 0)
  5859.                              then DevType := dtRAM;
  5860.                             FreeDosPtr(DPB);
  5861.                           end;
  5862.                        end;
  5863.                       GetStdDriveType := DevType;
  5864.                     end
  5865.          else begin                       { Standard DOS block device       }
  5866.                 IsRemoveable  := Info.DeviceAttr and bdaNotRemoveable = 0;
  5867.                 HasChangeLine := Info.DeviceAttr and bdaHasChangeLine <> 0;
  5868.                 GetStdDriveType := DevType;
  5869.                  if (DevType = dtFixedDisk) and
  5870.                     (Info.NumFATs = 1) and (Info.NumHeads = 1)
  5871.                   then GetStdDriveType := dtRAM;
  5872.               end;
  5873.       end;
  5874.     end;
  5875. end;
  5876.  
  5877. { Determine the properties of a given drive volume                     }
  5878. { The following assumptions have to be made about local file/dir paths:}
  5879. { Non-LFN:                                                             }
  5880. {   MaxNameLen = 12 (FILENAME.EXT)                                     }
  5881. {   MaxPathLen = 79 (Including local drive name)                       }
  5882. {   MaxExtLen  = 4  (.EXT)                                             }
  5883. {                                                                      }
  5884. { LFN:                                                                 }
  5885. {   MaxExtLen = 4 if MaxNameLen = 12 else MaxExtLen = MaxNameLen - 1   }
  5886.  
  5887. type
  5888.   PLfnRootVolInfo = ^TLfnRootVolInfo;
  5889.   TLfnRootVolInfo = record
  5890.     FileSysName: array[0..High(TFileSysName)] of Char;
  5891.     RootName   : array[0..3] of Char;
  5892.   end;
  5893.  
  5894. function GetVolumeSerialNum(Drive: Char): DWord;
  5895. type
  5896.   PDiskSerialInfo = ^TDiskSerialInfo;
  5897.   TDiskSerialInfo = record
  5898.     CallLevel  : Word;
  5899.     SerialNum  : DWord;
  5900.     VolLabel   : array[0..10] of Char;
  5901.     FileSysName: array[0..7] of Char;
  5902.   end;
  5903. var
  5904.   Regs      : TRegisters;
  5905.   SerialInfo: PDiskSerialInfo absolute DosBuf;
  5906.   SaveBuf   : TDiskSerialInfo;
  5907. begin
  5908.   GetVolumeSerialNum := 0;
  5909.   if DosVersion < $400
  5910.    then Exit;
  5911.   CheckDosBuf(SaveBuf, SizeOf(SaveBuf));
  5912.   FillChar(SerialInfo^, SizeOf(SerialInfo^), 0);
  5913.   ClearRegs(Regs);
  5914.   Regs.AX := $440D;                  { Generic IOCTL - block device request }
  5915.   Regs.CX := $0866;                  { Disk Drive - Get Volume Serial number}
  5916.   Regs.BL := Ord(DosUpCase(Drive)) - (Ord('A') - 1);
  5917.   Regs.DS := DosBuf.RealSeg;         { DS.DX = @SerialInfo                  }
  5918.   MsDos(Regs);
  5919.   if Regs.Flags and fCarry = 0
  5920.    then GetVolumeSerialNum := SerialInfo^.SerialNum;
  5921.   RestoreDosBuf(SaveBuf, SizeOf(SaveBuf));
  5922. end;
  5923.  
  5924. procedure SetVolumeInfo(VolInfo: PVolumeInfo);
  5925.  
  5926. var
  5927.   Regs         : TRegisters;
  5928.   IsRemoveable : Boolean;
  5929.   HasChangeLine: Boolean;
  5930.   Attr         : Word;
  5931.   j            : Integer;
  5932.   P            : PNetNet absolute DosBuf;
  5933.   SaveBuf      : TNetNet;
  5934.   SR           : TSearchRec;
  5935. {$ifdef LongNames}
  5936.   LfnInfo      : PLfnRootVolInfo absolute DosBuf;
  5937.   VolInfoBuf   : TLfnRootVolInfo absolute SaveBuf;
  5938. {$endif LongNames}
  5939. begin
  5940.   ClearRegs(Regs);
  5941.   Regs.Flags := fCarry;
  5942.   Attr := 0;
  5943. {$ifdef LongNames}
  5944.   if VFat then          { Set Win95 attributes flags and FileSysName fields }
  5945.    begin
  5946.      CheckDosBuf(VolInfoBuf, SizeOf(VolInfoBuf));
  5947.      Regs.AX := $71A0;
  5948.      Regs.CX := SizeOf(TFileSysName);    { CX = SizeOf(LfnInfo.FileSysName) }
  5949.      Regs.DX := SizeOf(TFileSysName);    { DS:DX = @LfnInfo.RootName        }
  5950.      Regs.ES := DosBuf.RealSeg;          { ES:DI = @LfnInfo.FileSysName     }
  5951.      Regs.DS := Regs.ES;
  5952.      PasToNull(VolInfo^.DriveName + '\', @LfnInfo^.RootName);
  5953.      MsDos(Regs);
  5954.      if Regs.Flags and fCarry = 0
  5955.       then begin
  5956.              Attr := Regs.BX and      { Just keep Win95 flags we know about }
  5957.                        (vaCaseSensitive + vaCasePreserve + vaUnicodeChars +
  5958.                         vaDosLongNames + vaCompressed);
  5959.              VolInfo^.MaxNameLen := Regs.CX;       { CX excludes the null   }
  5960.              VolInfo^.MaxExtLen  := Regs.CX;       { Can start with a '.'   }
  5961.              VolInfo^.MaxPathLen := Regs.DX-1;     { DX includes the null!  }
  5962.              if Regs.CX = fsDosName
  5963.               then VolInfo^.MaxExtLen := fsDosExt;
  5964.              VolInfo^.FileSysName:= NullToPas(@LfnInfo^.FileSysName);
  5965.            end
  5966.       else begin
  5967.              { This code has to assume $71A0 will fail (carry = 1) with AX  }
  5968.              { unchanged or = $7100 on a non-LFN system. There is no other  }
  5969.              { way of detectng LFN support except by checking for the       }
  5970.              { presence of Win9x. $71A0 on Win9x will fail if no media is in}
  5971.              { the drive. It has to be assumed AX will not equal $71A0 under}
  5972.              { these circumstances under any LFN capable system.            }
  5973.  
  5974.              if (Regs.AX <> $7100) and (Regs.AX <> $71A0) { function supptd }
  5975.               then Attr := vaDosLongNames + vaIsRemoveable + vaNoDiskInDrive;
  5976.              Attr := VolInfo^.Attributes or Attr;
  5977.            end;
  5978.      RestoreDosBuf(VolInfoBuf, SizeOf(VolInfoBuf));
  5979.    end;
  5980. {$endif LongNames}
  5981.  
  5982.   IsRemoveable := false;
  5983.   HasChangeLine:= false;
  5984.  
  5985.   { Get Drive type, IsRemovable and Has ChangeLine attributes. }
  5986.  
  5987.   if VolInfo^.NetName <> nil
  5988.    then Attr := Attr or (vaIsNetWorkDrive + vaIsRemoveable) { Network drive }
  5989.    else VolInfo^.DriveType := GetStdDriveType(VolInfo^.DriveName[1],
  5990.                                               IsRemoveable, HasChangeLine);
  5991.   if VolInfo^.FileSysName = '' then
  5992.    begin
  5993.      VolInfo^.MaxNameLen := fsDosName;
  5994.      VolInfo^.MaxPathLen := fsDosPath;
  5995.      VolInfo^.MaxExtLen  := fsDosExt;
  5996.      if VolInfo^.DriveType = dtCdRom
  5997.       then VolInfo^.FileSysName:= 'CDFS'
  5998.       else VolInfo^.FileSysName:= 'FAT';
  5999.  
  6000.    end;
  6001.  
  6002.   if IsRemoveable then
  6003.    begin
  6004.      Attr := Attr or vaIsRemoveable;             { Drive media is removable }
  6005.      if HasChangeLine then
  6006.       begin
  6007.         Inc(Attr, vaHasChangeLine);
  6008.         if (Attr and vaNoDiskInDrive = 0) and    { When not under LFN O/S   }
  6009.            (CheckDrvMedia(VolInfo) = mcNotReady)
  6010.          then Inc(Attr, vaNoDiskInDrive);
  6011.       end;
  6012.    end;
  6013.  
  6014.   VolInfo^.Attributes := Attr;
  6015.  
  6016.   if (VolInfo^.NetName = nil) then
  6017.    begin
  6018.      { Return the network-style equivalent name of the local drive       }
  6019.      { because some non-networked local drives may have a network-style  }
  6020.      { cannonical name. NWCDEX for example returns network-style names   }
  6021.  
  6022.      CheckDosBuf(SaveBuf, SizeOf(SaveBuf));
  6023.      PasToNull(VolInfo^.DriveName, @P^.NetPath);
  6024.      AddDirSepStr(@P^.NetPath);
  6025.      ClearRegs(Regs);
  6026.      Regs.Flags := fCarry;
  6027.      Regs.ES := DosBuf.RealSeg;        { Regs.ES:DI = @P^.LongPath (o/p)    }
  6028.      Regs.DS := Regs.ES;
  6029.      Regs.SI := SizeOf(TPathNet);      { Regs.DS:SI = @P^.NetPath (i/p name)}
  6030.      Regs.AH := $60;                   { DOS - Get cannonical true name     }
  6031.  {$ifdef LongNames}
  6032.      if Attr and vaDosLongNames <> 0 then
  6033.       begin
  6034.         Regs.AX := $7160;              { LFN - Get cannonical LFN or path   }
  6035.         Regs.CX := $0002;              { Return network drive name          }
  6036.       end;
  6037.  {$endif LongNames}
  6038.      MsDos(Regs);
  6039.      if (Regs.Flags and fCarry = 0) and
  6040.         (StrComp(@P^.LongPath, @P^.NetPath) <> 0) then
  6041.       begin
  6042.         DelDirSepStr(@P^.LongPath);
  6043.         VolInfo^.NetName := PNetName(NewStr(StrPas(@P^.LongPath)));
  6044.       end;
  6045.      RestoreDosBuf(SaveBuf, SizeOf(SaveBuf));
  6046.    end;
  6047.  
  6048.   VolInfo^.MediaState := mcNo;                     { Clear media changed    }
  6049.  
  6050.   { Get the volume label }
  6051.  
  6052.   if Volinfo^.Attributes and vaNoDiskInDrive = 0 then
  6053.    begin
  6054.      if FindFirst(Volinfo^.DriveName + '\*.*', faVolumeID, SR)
  6055.       then begin
  6056.              j := Pos('.', SR.Name);
  6057.              if j <> 0
  6058.               then Delete(SR.Name, j, 1);
  6059. {$ifdef LongNames}
  6060.              if Volinfo^.Attributes and vaCaseSensitive = 0 then
  6061. {$endif LongNames}
  6062.               begin
  6063.                 {$V-} DosLowerCase(SR.Name); {$V+}
  6064.                 SR.Name[1] := DosUpCase(SR.Name[1]);
  6065.               end;
  6066.              Volinfo^.VolumeLabel := SR.Name;
  6067.              FindClose(SR);
  6068.            end
  6069.       else begin
  6070.              Volinfo^.VolumeLabel := '';
  6071.              DosError := deNoError;
  6072.            end;
  6073.  
  6074.      { Get volume serial number }
  6075.  
  6076.      Volinfo^.SerialNum := GetVolumeSerialNum(Volinfo^.DriveName[1]);
  6077.    end;
  6078. end;
  6079.  
  6080. { Return a redirected device entry into the specified buffers }
  6081.  
  6082. type
  6083.   PNetDevName = ^TNetDevName;
  6084.   TNetDevName = record
  6085.     Local: array[0..15] of char;
  6086.     Net  : array[0..127] of char;
  6087.   end;
  6088.  
  6089. function GetRedirEntry(Entry: Word): Byte;
  6090. {$ifdef DPMI}
  6091. var
  6092.   Regs: TRegisters;
  6093. begin
  6094.   ClearRegs(Regs);
  6095.   Regs.DS := DosBuf.RealSeg;
  6096.   Regs.ES := Regs.DS;
  6097.   Regs.DI := 16;                            { ES:DI = @Net name buffer      }
  6098.   Regs.AX := $5F02;                         { DOS Get Redirection list entry}
  6099.   Regs.BX := Entry;
  6100.   Regs.CX := 0;
  6101.   MsDos(Regs);
  6102.   GetRedirEntry := Byte(-1);
  6103.   if (Regs.Flags and fCarry = 0) and (Regs.BH <> 1)
  6104.    then GetRedirEntry := Regs.BL;
  6105. end;
  6106. {$else DPMI} assembler;
  6107. asm
  6108.           push  ds
  6109.           lds   si,[DosBuf.RealBuf]         { DS:SI = @Local name buffer    }
  6110.           push  ds
  6111.           mov   di,TNetDevName.Net          { ES:DI = @Net name buffer      }
  6112.           pop   es
  6113.           mov   ax,$5F02                    { DOS Get Redirection list entry}
  6114.           mov   bx,[Entry]
  6115.           mov   cx,0
  6116.           int   intDos
  6117.           pop   ds
  6118.           mov   al,-1
  6119.           jc    @@Exit
  6120.           cmp   bh,1
  6121.           je    @@Exit
  6122.           mov   ax,bx
  6123. @@Exit:
  6124. end;
  6125. {$endif DPMI}
  6126.  
  6127. { Returns the first networked drive. Adds all networked and CD-ROM  }
  6128. { drives to the valid drive list the first time it's called.        }
  6129.  
  6130. function Get1stNetDrive: PVolumeInfo;
  6131. var
  6132.   V         : PVolumeInfo;
  6133.   Result    : PVolumeInfo;
  6134.   j         : Word;
  6135.   DevType   : Byte;
  6136.   Padder    : Byte;
  6137.   NetDevName: PNetDevName absolute DosBuf;
  6138.   SaveBuf   : TNetDevName;
  6139. begin
  6140.   if VolumeList = nil then
  6141.    begin
  6142.      Get1stNetDrive := nil;
  6143.      CheckDosBuf(SaveBuf, SizeOf(SaveBuf));
  6144.      GetDrives;                             { Make sure DriveList is defined}
  6145.      for j := 0 to 99 do
  6146.       begin
  6147.         DevType := GetRedirEntry(j);
  6148.         if DevType = dtError
  6149.          then Break;
  6150.         if (DevType = 4) and                { Network device must be a drive}
  6151.            (NetDevName^.Local[1] = ':') and { mapped to a local drive letter}
  6152.            (Pos(NetDevName^.Local[0], DriveList) <> 0) then
  6153.          begin
  6154.            V := CreateVolume(NetDevName^.Local[0]);
  6155.            V^.DriveType := dtNet1;
  6156.            V^.DriveName := StrLPas(NetDevName^.Local, 2); { Local drive name}
  6157.            if Length(V^.DriveName) = 1
  6158.             then V^.DriveName := V^.DriveName + ':'
  6159.             else V^.DriveName[0] := #2;                { Network drive name }
  6160.            V^.NetName := PNetName(NewStr(NullToPas(@NetDevName^.Net)));
  6161.            SetVolumeInfo(V);               { Set rest of TVolumeInfo fields }
  6162.          end;
  6163.       end;
  6164.      RestoreDosBuf(SaveBuf, SizeOf(SaveBuf));
  6165.    end;
  6166.   Result := VolumeList;
  6167.   while Result <> nil do
  6168.    if Result^.Attributes and vaIsNetWorkDrive <> 0
  6169.     then Break
  6170.     else Result := Result^.Next;
  6171.   Get1stNetDrive := Result;
  6172. end;
  6173.  
  6174. procedure InsertVolume(V: PVolumeInfo);  { Add V to List of defined volumes }
  6175. var
  6176.   P: ^PVolumeInfo;
  6177. begin
  6178.   P := @VolumeList;
  6179.   while (P^ <> nil) and (V^.DriveName[1] > P^^.DriveName[1]) do
  6180.     P := @P^^.Next;
  6181.   V^.Next := P^;
  6182.   P^ := V;
  6183. end;
  6184.  
  6185. function StdCreateVolume(Drive: Char): PVolumeInfo; far;
  6186. var
  6187.   V: PVolumeInfo;
  6188. begin
  6189.   New(V);                                       { Represents a valid drive  }
  6190.   FillChar(V^, SizeOf(V^), 0);
  6191.   V^.DriveName := Drive + ':';
  6192.   InsertVolume(V);
  6193.   StdCreateVolume := V;
  6194. end;
  6195.  
  6196. function GetVolumeInfo(Drive: Char): PVolumeInfo;
  6197. var
  6198.   V: PVolumeInfo;
  6199. begin
  6200.   Drive := DosUpCase(Drive);
  6201.   V := VolumeList;
  6202.   if V = nil
  6203.    then V := Get1stNetDrive;                    { Define all network drives }
  6204.   while V <> nil do                             { Look for predefined volume}
  6205.    begin
  6206.      if V^.DriveName[1] = Drive then
  6207.       begin
  6208.         GetVolumeInfo := V;
  6209.  
  6210.         { Check the media state flag. If it is not mcNo }
  6211.         { then refresh the volume information.          }
  6212.  
  6213.         if V^.MediaState <> mcNo
  6214.          then SetVolumeInfo(V);                 { If there was no media in  }
  6215.         Exit;                                   { drive last time then try  }
  6216.       end;                                      { to set volume info again. }
  6217.      V := V^.Next;
  6218.    end;
  6219.   if DriveValid(Drive)
  6220.    then begin                                   { Not predefined, so create }
  6221.           V := CreateVolume(Drive);             { new volume if drive letter}
  6222.           SetVolumeInfo(V);
  6223.        end
  6224.    else DosError := deInvalidDrive;
  6225.   GetVolumeInfo := V;                           { nil if Drive is invalid   }
  6226. end;
  6227.  
  6228. (*
  6229. function CheckCdMedia(Drive: Char): TMediaLevel;
  6230. type
  6231.   PCdMediaChk = ^TCdMediaChk;
  6232.   TCdMediaChk = record
  6233.     DataLen   : Byte;                { 00 }
  6234.     SubUnit   : Byte;                { 01 }
  6235.     Command   : Byte;                { 02 }
  6236.     Status    : Word;                { 03 }
  6237.     Reserved  : array[0..3] of Byte; { 05 }
  6238.     NextHeader: PCdMediaChk;         { 09 }
  6239.     Media     : Byte;                { 0D }
  6240.     MediaState: Byte;                { 0E }
  6241.     PrevID    : PChar;               { 0F }
  6242.   end;
  6243. var
  6244.   Regs   : TRegisters;
  6245.   SaveBuf: TCdMediaChk;
  6246.   Data   : PCdMediaChk absolute DosBuf;
  6247. begin
  6248.   CheckDosBuf(SaveBuf, SizeOf(SaveBuf));
  6249.   Data^.DataLen := SizeOf(SaveBuf);
  6250.   Data^.Command := $01;
  6251.   ClearRegs(Regs);
  6252.   Regs.AX := $1510;                   { MSCDEX - Send Device Driver Request }
  6253.   Regs.CX := Ord(Drive) - (Ord('A')-1);                     { Drive Letter  }
  6254.   Intr($2F, Regs);
  6255.   if (Regs.Flags and fCarry <> 0) or (Data^.Status and $80 <> 0)
  6256.    then CheckCdMedia := mcUnknown
  6257.    else if Data^.MediaState = 9
  6258.           then CheckCdMedia := mcNotReady
  6259.           else case Data^.MediaState of
  6260.                  $00:
  6261.                    CheckCdMedia := mcUnknown;
  6262.                  $01:
  6263.                    CheckCdMedia := mcNo;
  6264.                  else
  6265.                    CheckCdMedia := mcYes;
  6266.                end;
  6267.   RestoreDosBuf(SaveBuf, SizeOf(SaveBuf));
  6268. end;
  6269. *)
  6270.  
  6271. { Return the Media Changed status for a Drive }
  6272.  
  6273. function CheckDrvMedia(V: PVolumeInfo): TMediaLevel; assembler;
  6274. var
  6275.   Regs: TRegisters;
  6276. asm
  6277.             les   di,[V]
  6278.             test  es:[di].TVolumeInfo.Attributes,vaNoDiskInDrive
  6279.             mov   al,mcNotready
  6280.             jnz   @@Exit
  6281.             test  es:[di].TVolumeInfo.Attributes,vaIsRemoveable
  6282.             mov   al,mcNo
  6283.             je    @@Exit
  6284.             test  es:[di].TVolumeInfo.Attributes,vaHasChangeLine
  6285.             jnz   @@ChkLine
  6286.             push  es:[di].TVolumeInfo.DriveName.Word[1]
  6287.             call  GetVolumeSerialNum
  6288.             les   di,[V]
  6289.             mov   cx,ax
  6290.             mov   al,mcYes
  6291.             cmp   cx,es:[di].TVolumeInfo.SerialNum.Word[0]
  6292.             jne   @@Exit
  6293.             cmp   dx,es:[di].TVolumeInfo.SerialNum.Word[2]
  6294.             jne   @@Exit
  6295.  
  6296. { The serial numbers are the same, but they might be both zero (unsupported)}
  6297.  
  6298.             or    cx,dx         { If they are non-zero, they are valid and  }
  6299.             mov   al,mcNo       { the media has definately not changed.     }
  6300.             jne   @@Exit
  6301.             mov   al,mcUnknown  { There is no serial number, so we don't    }
  6302.             jmp   @@Exit        { know if the media has changed or not.     }
  6303. {$ifdef MsDos}
  6304. @@ChkLine:  mov   ah,$16
  6305.             mov   dl,es:[di].TVolumeInfo.DriveName.Byte[1]
  6306.             sub   dl,'A'
  6307.             int   $13
  6308. {$else MsDos}
  6309. @@ChkLine:  push  ss
  6310.             mov   dl,es:[di].TVolumeInfo.DriveName.Byte[1]
  6311.             sub   dl,'A'
  6312.  
  6313.             lea   di,Regs
  6314.             pop   es                        { ES:DI = @RealRegs             }
  6315.             cld
  6316.             mov   cx,type TRegisters / 2
  6317.             xor   ax,ax
  6318.             rep   stosw
  6319.  
  6320.             mov   [Regs.&AH],$16            { RealRegs.AH = $16             }
  6321.             lea   di,Regs                   { ES:DI = @Regs                 }
  6322.             mov   [Regs.&DX],dx             { DL = Drive number (A = 0)     }
  6323.             mov   ax,$300                   { Call real-mode interrupt      }
  6324.             mov   bx,$0013                  { BL = interrupt number (Disk)  }
  6325.             int   $31                       { CX already equals 0           }
  6326.             mov   ax,[Regs.&AX]             { CF = 0, AH = 0 if not changed }
  6327.             shr   [Regs.Flags],1            { Real Mode carry -> CF         }
  6328. {$endif MsDos}
  6329.             mov   al,mcUnknown
  6330.             jc    @@Exit                    { Function failed               }
  6331.             cmp   ah,-1                     { Detection system failed       }
  6332.             je    @@Exit
  6333.             cmp   ah,$80
  6334.             mov   al,mcNotReady
  6335.             jz    @@Exit                    { Drive not ready               }
  6336.             mov   al,mcNo                   { Assume drive media not changed}
  6337.             cmp   ah,0
  6338.             je    @@Exit
  6339.             mov   al,mcYes                  { Drive media has changed       }
  6340. @@Exit:     mov   es:[di].TVolumeInfo.MediaState,al
  6341. end;
  6342.  
  6343. function GetVolumeLabel(Drive: Char): TVolLabel;
  6344. var
  6345.   V: PVolumeInfo;
  6346. begin
  6347.   DosUpCase(Drive);
  6348.   V := GetVolumeInfo(Drive);
  6349.   if V = nil
  6350.    then GetVolumeLabel := '';
  6351.   GetVolumeLabel := V^.VolumeLabel;
  6352. end;
  6353.  
  6354. function GetVolumeLabelStr(VolLabel: PChar; Drive: Char): PChar;
  6355. var
  6356.   V: PVolumeInfo;
  6357. begin
  6358.   V := GetVolumeInfo(Drive);
  6359.   if V = nil
  6360.    then VolLabel^ := asNull
  6361.    else PasToNull(V^.VolumeLabel, VolLabel);
  6362.   GetVolumeLabelStr := VolLabel;
  6363. end;
  6364.  
  6365. type
  6366.   PDosFcb = ^TDosFcb;
  6367.   TDosFcb = record                  { DOS extended File Control Block       }
  6368.     Flag   : Byte;                  { must be $ff! }
  6369.     Reserv1: array[1..5] of Byte;
  6370.     Attr   : Byte;
  6371.     Drive  : Byte;
  6372.     Name   : array[1..8] of Char;
  6373.     Ext    : array[1..3] of Char;
  6374.     FPos   : Word;
  6375.     RecSize: Word;
  6376.     FSize  : LongInt;
  6377.     FDate  : Word;
  6378.     FTime  : Word;
  6379.     Reserv2: array[1..8] of Byte;
  6380.     CurRec : Byte;
  6381.     RelRec : LongInt;
  6382.   end;
  6383.  
  6384. procedure SetFcbName(var Fcb: TDosFcb; Name: TNameExt);
  6385. var
  6386.   P,X: Byte;
  6387. begin
  6388.   P := Pos('.', Name);
  6389.   if P = 0 then
  6390.    begin
  6391.      P := Length(Name)+1;
  6392.      Name := Name + '.';
  6393.    end;
  6394.   FillChar(Fcb.Name, 11, ' ');
  6395.   Move(Name[1], Fcb.Name, P-1);
  6396.   Move(Name[P+1], Fcb.Ext, Length(Name)-P);
  6397. end;
  6398.  
  6399. { Call a Dos Fcb function. The DosBuf memory buffer must point to a }
  6400. { predefined DOS extended File Control Block. This function can be  }
  6401. { used for any DOS function that takes a pointer to a memory block  }
  6402. { in DS:DX and an error code is returned in AL.                     }
  6403.  
  6404. function CallDosFcb(Fn: Word): Byte; assembler;
  6405. {$ifdef DPMI}
  6406. var
  6407.   Regs: TRegisters;
  6408. asm
  6409.             mov   dx,word ptr [DosBuf.RealSeg]  { DX:0000 = DosBuf (real)   }
  6410.             push  ss
  6411.             lea   di,Regs
  6412.             pop   es                        { ES:DI = @RealRegs             }
  6413.             cld
  6414.             mov   cx,type TRegisters / 2
  6415.             xor   ax,ax
  6416.             rep   stosw
  6417.             mov   ax,[Fn]
  6418.             lea   di,Regs                   { ES:DI = @Regs                 }
  6419.             mov   [Regs.&AX],ax             { RealRegs.AX = Fn              }
  6420.             mov   ax,dpmiCallRealInt        { Call real-mode interrupt      }
  6421.             mov   [Regs.&DS],dx             { Regs.DS:DX = DosBuf.RealBuf   }
  6422.             mov   bx,intDos                 { BL = interrupt number ($21)   }
  6423.             int   $31                       { CX already equals 0           }
  6424.             mov   ax,[Regs.&AX]
  6425. {$else DPMI}
  6426. asm
  6427.             push  ds
  6428.             push  bp
  6429.             lds   dx,[DosBuf.RealBuf]       { DS:DX = DosBuf                }
  6430.             mov   ax,[Fn]
  6431.             int   intDos
  6432.             pop   bp
  6433.             pop   ds
  6434. {$endif DPMI}
  6435. end;
  6436.  
  6437. function SetVolumeLabel(Drive: Char; VolLabel: TVolLabel): Boolean;
  6438. var
  6439.   Fcb    : PDosFcb absolute DosBuf;
  6440.   SaveBuf: TDosFcb;
  6441.   V      : PVolumeInfo;
  6442. label
  6443.   Done;
  6444. begin
  6445.   DosUpCase(Drive);
  6446.   {$V-} DosUpperCase(VolLabel); {$V+}
  6447.   SetVolumeLabel := false;
  6448.   DosError := deInvalidDrive;
  6449.   V := GetVolumeInfo(Drive);
  6450.   if V = nil
  6451.    then Exit;
  6452.   DosError := deAccessDenied;
  6453.   if V^.Attributes and vaIsNetworkDrive <> 0
  6454.    then Exit;
  6455.   CheckDosBuf(SaveBuf, SizeOf(SaveBuf));
  6456.   Fcb^.Flag := $FF;
  6457.   Fcb^.Attr := faVolumeID;
  6458.   if V^.VolumeLabel <> '' then
  6459.    begin
  6460.      SetFcbName(Fcb^, V^.VolumeLabel);
  6461.      Fcb^.Drive := Byte(Drive) - (Ord('A') - 1);
  6462.      if CallDosFcb($1300) <> 0          { Delete File }
  6463.       then goto Done;
  6464.      V^.VolumeLabel := ''
  6465.    end;
  6466.   if VolLabel <> '' then
  6467.    begin
  6468.      Fcb^.Drive := Byte(Drive) - (Ord('A') - 1);
  6469.      SetFcbName(Fcb^, VolLabel);
  6470.      if (CallDosFcb($1600) <> 0) or     { Create File }
  6471.         (CallDosFcb($1000) <> 0)        { Close File  }
  6472.       then Exit;
  6473.      V^.VolumeLabel := VolLabel;
  6474.    end;
  6475.   DosError := deNoError;
  6476.   SetVolumeLabel := true;
  6477. Done:
  6478.   RestoreDosBuf(SaveBuf, SizeOf(SaveBuf));
  6479. end;
  6480.  
  6481. function SetVolumeLabelStr(VolLabel: PChar; Drive: Char): Boolean;
  6482. begin
  6483.   SetVolumeLabelStr := SetVolumeLabel(Drive, StrLPas(VolLabel, fsVolLabel));
  6484. end;
  6485.  
  6486. { Looks for a network drive net at the start of Path. Replaces the network  }
  6487. { drive name with its local (X:\) drive name if the network drive name is   }
  6488. { found in the valid list of drives, else sets DosError to "Path not Found" }
  6489. { Path contains a valid drive, but it may not have a TVolumeInfo assigned it}
  6490.  
  6491. function ConvertNetPath(Path: PChar): PVolumeInfo;
  6492. var
  6493.   V   : PVolumeInfo;
  6494.   P   : Word;
  6495.   j   : Byte;
  6496.   Pad : Byte;
  6497.   Name: array[0..fsNetName] of Char;
  6498. const
  6499.   CheckCD: Boolean = false;
  6500. begin
  6501.   StrLCopy(@Name, Path, fsNetName);
  6502.   StrUpper(@Name);                     { Net paths must be case insensitive }
  6503.   P := 0;
  6504.   if not CheckCD then                  { Some MSCDEX drivers return network }
  6505.    begin                                        { style cannonocal paths so }
  6506.      for j := Length(GetDrives) downto 1 do     { make sure all MSCDEX      }
  6507.       if IsCdRom(DriveList[j])                  { drives are defined.       }
  6508.        then GetVolumeInfo(DriveList[j]);
  6509.      CheckCD := true;
  6510.    end;
  6511.   Get1stNetDrive;                      { Ensure all net drives are defined  }
  6512.   V := VolumeList;
  6513.   while V <> nil do
  6514.    begin
  6515.      if (V^.NetName <> nil) and
  6516.         (StrLComp(@V^.NetName^[1], @Name, Length(V^.NetName^)) = 0) then
  6517.       begin                                         { Net drv name found at }
  6518.         P := Length(V^.NetName^);                   { the start of Path.    }
  6519.         if (P = StrLen(@Name)) or (Name[P] = '\') then
  6520.          begin
  6521.            StrMove(@Path[2], @Path[P], StrLen(@Name[P])+1);{ Remove net name}
  6522.            Move(V^.DriveName[1], Path^, 2);                { Set local name }
  6523.            DosError := deNoError;
  6524.            ConvertNetPath := V;
  6525.            Exit;
  6526.          end;
  6527.       end;
  6528.      V := V^.Next;
  6529.    end;
  6530.   DosError := deInvalidDrive;          { Path (network drive) not found     }
  6531.   ConvertNetPath := nil;
  6532. end;
  6533.  
  6534. { Determine the volume from a path. The network drive name of a network  }
  6535. { path is converted to its local drive equivalent.  'X:' is appended if  }
  6536. { Path is relative ("\[DIR\]NAME.EXT", "..\NAME.EXT" or "[DIR\]NAME.EXT" }
  6537. { Returns nil and set DosError to "Invalid Drive" if drive not found.    }
  6538.  
  6539. function GetVolumeFromPath(Path: PChar): PVolumeInfo;
  6540. var
  6541.   C: Char;
  6542.   P: Char;
  6543.   L: Integer;
  6544.   T: TPathName;
  6545. const
  6546.   NetPath: array[0..1] of Char = '\\'; { Network paths must start with '\\' }
  6547. begin
  6548.   L := StrLen(Path);
  6549.   if L = 0 then
  6550.    begin
  6551.      GetVolumeFromPath := nil;
  6552.      Exit;
  6553.    end;
  6554.  {SlashConvert(L, Path);}
  6555.   C := Path[0];
  6556.   if PWord(Path)^ = Word(NetPath)
  6557.    then GetVolumeFromPath := ConvertNetPath(Path)
  6558.    else begin
  6559.           if (C = '\') or (Path[1] <> ':')
  6560.            then begin
  6561.                   C := GetCurDrive;
  6562.                   Move(Path^, Path[2], StrLen(Path)+1);
  6563.                   Path[0] := C;
  6564.                   Path[1] := ':';
  6565.                 end
  6566.            else begin
  6567.                   Path[0] := UpCase(Path[0]);  { Make sure the drive letter }
  6568.                   C := Path[0];                { is an uppercase letter     }
  6569.                 end;
  6570.           GetVolumeFromPath := GetVolumeInfo(C);
  6571.  
  6572.      { Some versions of DOS (eg 7.x) will treat "X:" as an invalid path, }
  6573.      { so we have to add any implied current directory.                  }
  6574.  
  6575.           if Path[2] <> '\' then
  6576.            begin
  6577.              StrCopy(@T, @Path[2]);            { Save everything after "X:" }
  6578.              GetCurDir(Path, Ord(C) - (Ord('A')-1)); { Get Drive + directory}
  6579.              StrLCat(Path, @T, fsNetPath);     { Add the rest of passed path}
  6580.            end;                                { to "X:\CURDIR\"            }
  6581.         end;
  6582. end;
  6583.  
  6584. function GetVolumeOf(const Path: TNetPath): PVolumeInfo;
  6585. var
  6586.   P: array[0..fsNetPath] of Char;
  6587. begin
  6588.   StrPCopy(@P, Path);
  6589.   GetVolumeOf := GetVolumeFromPath(@P);
  6590. end;
  6591.  
  6592. function GetVolumeOfStr(Path: PChar): PVolumeInfo;
  6593. var
  6594.   P: array[0..fsNetPath] of Char;
  6595. begin
  6596.   StrLCopy(@P, Path, fsNetPath);
  6597.   GetVolumeOfStr := GetVolumeFromPath(@P);
  6598. end;
  6599.  
  6600. {------------------- Standard Disk/Drive related functions -----------------}
  6601.  
  6602. function GetVerify: Boolean;
  6603. {$ifdef TurboDos} assembler;
  6604. asm
  6605.             mov   ah,$54                    { DOS - Get Verify Flag         }
  6606.             int   intDos
  6607. end;
  6608. {$else TurboDos}
  6609. var
  6610.   Regs: TRegisters;
  6611. begin
  6612.   ClearRegs(Regs);
  6613.   Regs.AH := $54;                           { DOS - Get Verify Flag         }
  6614.   GetVerify := Lo(MsDos(Regs)) <> 0;
  6615. end;
  6616. {$endif TurboDos}
  6617.  
  6618. procedure SetVerify(Verify: Boolean);
  6619. {$ifdef TurboDos} assembler;
  6620. asm
  6621.             mov   ah,$2E                    { DOS - Set Verify Flag         }
  6622.             mov   al,[Verify]
  6623.             int   intDos
  6624. end;
  6625. {$else TurboDos}
  6626. var
  6627.   Regs: TRegisters;
  6628. begin
  6629.   ClearRegs(Regs);
  6630.   Regs.AL := Ord(Verify);
  6631.   Regs.AH := $2E;                           { DOS - Set Verify Flag         }
  6632.   Verify := Lo(MsDos(Regs)) <> 0;
  6633. end;
  6634. {$endif TurboDos}
  6635.  
  6636. { Replacement for System GetDir }
  6637.  
  6638. procedure LfnGetDir(D: Byte; var S: String; MaxLen: Word); far;
  6639. var
  6640.   Regs   : TRegisters;
  6641.   SaveBuf: TPathName;
  6642.   P      : PChar absolute DosBuf;
  6643.   Drive  : Char;
  6644.   Padder : Char;
  6645.   V      : PVolumeInfo;
  6646. begin
  6647.   S := '';
  6648.   CheckDosBuf(SaveBuf, SizeOf(SaveBuf));
  6649.   if D = 0
  6650.    then Drive := GetCurDrive
  6651.    else Drive := Chr(D + (Ord('A') - 1));
  6652.   PasToNull(Drive + ':\', P);
  6653.   V := GetVolumeInfo(Drive);
  6654.   if V = nil
  6655.    then DosError := deInvalidDrive
  6656.    else begin
  6657.           ClearRegs(Regs);
  6658.           Regs.DL := D;
  6659.           Regs.DS := DosBuf.RealSeg;
  6660.           Regs.SI := SizeOf(Char) * 3;       { @Next char after 'X:\' drive }
  6661.           Regs.AH := $47;                    { DOS - Get current directory  }
  6662. {$ifdef LongNames}
  6663.           if V^.Attributes and vaDosLongNames <> 0
  6664.            then Regs.AX := $7147;            { LFN - Get current directory  }
  6665. {$endif LongNames}
  6666.           Regs.Flags := fCarry;
  6667.           DosError := MsDos(Regs);
  6668.           if Regs.Flags and fCarry = 0 then
  6669.            begin
  6670.              DosError := deNoError;
  6671.              ConvertPathCase(P, V);          { Do any case conversions req'd}
  6672.              AddDirSepStr(P);
  6673. {$ifdef Windows}
  6674.              OemToAnsi(P, P);
  6675. {$endif Windows}
  6676.            end;
  6677.         end;
  6678.   S := StrLPas(P, MaxLen);
  6679.   if DosError = deNoError
  6680.    then DosError := StrError;
  6681.   RestoreDosBuf(SaveBuf, SizeOf(SaveBuf));
  6682. end;
  6683.  
  6684. procedure GetDir(Drive: Byte; var S: String);
  6685. begin
  6686.   LfnGetDir(Drive, S, High(S));
  6687. end;
  6688.  
  6689. function GetCurDir(S: PChar; Drive: Byte): PChar;
  6690. var
  6691.   Regs   : TRegisters;
  6692.   P      : PChar absolute DosBuf;
  6693.   SaveBuf: TPathName;
  6694.   D      : Char;
  6695.   Padder : Char;
  6696.   V      : PVolumeInfo;
  6697. begin
  6698.   GetCurDir := S;
  6699.   CheckDosBuf(SaveBuf, SizeOf(SaveBuf));
  6700.   if Drive = 0
  6701.    then D := GetCurDrive
  6702.    else D := Chr(Drive + (Ord('A') - 1));
  6703.   PasToNull(D + ':\', P);
  6704.   V := GetVolumeInfo(D);
  6705.   if V = nil
  6706.    then DosError := deInvalidDrive
  6707.    else begin
  6708.           Inc(P, 3);                         { Add cur dir to end of "X:\"  }
  6709.           ClearRegs(Regs);
  6710.           Regs.DL := Drive;
  6711.           Regs.DS := DosBuf.RealSeg;
  6712.           Regs.SI := 3;
  6713.           Regs.AH := $47;                    { DOS - Get current directory  }
  6714. {$ifdef LongNames}
  6715.           if V^.Attributes and vaDosLongNames <> 0
  6716.            then Regs.AX := $7147;            { LFN - Get current directory  }
  6717. {$endif LongNames}
  6718.           Regs.Flags := fCarry;
  6719.           DosError := MsDos(Regs);
  6720.           if Regs.Flags and fCarry = 0 then
  6721.            begin
  6722.              DosError := 0;
  6723.              PtrRec(P).Ofs := 0;             { Add the 'X:\' prefix to path }
  6724.              AddDirSepStr(P);                { Make sure it ends in a '\'   }
  6725.              ConvertPathCase(P, V);
  6726.            end;
  6727.         end;
  6728.   StrCopy(S, P);                             { Copy path into result        }
  6729.   PtrRec(P).Ofs := 0;
  6730. {$ifdef Windows}
  6731.   OemToAnsi(S, S);
  6732. {$endif Windows}
  6733.   RestoreDosBuf(SaveBuf, SizeOf(SaveBuf));
  6734. end;
  6735.  
  6736. procedure DoDirOp(var S: String; DosOp: Byte);
  6737. var
  6738.   Regs   : TRegisters;
  6739.   P      : PChar absolute DosBuf;
  6740.   SaveBuf: TPathNet;
  6741.   Path   : TPathNet;
  6742.   V      : PVolumeInfo;
  6743. label
  6744.   Done;
  6745. begin
  6746.   CheckDosBuf(SaveBuf, SizeOf(SaveBuf));
  6747.   ClearRegs(Regs);
  6748.   StrPLCopy(@Path, S, fsNetPath);
  6749.   if StrError <> deNoError then
  6750.    begin
  6751.      DosError := StrError;
  6752.      goto Done
  6753.    end;
  6754. {$ifdef Windows}
  6755.   AnsiToOem(@Path, @Path);
  6756. {$endif Windows}
  6757.   V := FileExpand(@Path, @Path, fcCasePreserve);
  6758.   if DosError <> deNoError
  6759.    then goto Done;
  6760.   StrCopy(P, @Path);
  6761.   Regs.DS := DosBuf.RealSeg;
  6762.   Regs.AH := DosOp;                         { DOS - Create/Remove Directory }
  6763.   Regs.Flags := fCarry;
  6764. {$ifdef LongNames}
  6765.   if V^.Attributes and vaDosLongNames <> 0
  6766.    then Regs.AX := $7100 + DosOp;           { LFN - Create/Remove Directory }
  6767. {$endif LongNames}
  6768.   DosError := MsDos(Regs);
  6769.   if Regs.Flags and fCarry = 0
  6770.    then DosError := 0
  6771.    else GetExtError;
  6772. Done:
  6773.   RestoreDosBuf(SaveBuf, SizeOf(SaveBuf));
  6774. end;
  6775.  
  6776. { Replacement for System MkDir }
  6777.  
  6778. procedure LfnMkDir(var S: String); far;
  6779. begin
  6780.   DoDirOp(S, $39); { DOS - Create Directory }
  6781. end;
  6782.  
  6783. procedure LfnRmDir(var S: String); far;
  6784. begin
  6785.   DoDirOp(S, $3A); { DOS - Remove Directory }
  6786. end;
  6787.  
  6788. procedure ChDir(Dir: String);      { Enhanced verion of System.ChDir that:  }
  6789. var                                { (1) Allows Dir to contain LFN dir names}
  6790.   Regs   : TRegisters;             { (2) Allows Dir to contain a net path   }
  6791.   V      : PVolumeInfo;            { (3) Allows paths containing subdirs to }
  6792.   L      : Word;
  6793. {$ifdef DPMI}                      {     end with or without a trailing '\' }
  6794.   P      : PChar absolute DosBuf;
  6795.   SaveBuf: array[0..fsDirectory] of Char;
  6796. {$else DPMI}
  6797.   P      : TPathName absolute Dir;
  6798. {$endif DPMI}
  6799. label
  6800.   Done;                           { Change Dir to a PChar^ and expand to Dir}
  6801. begin                             { To allow network names and to validate  }
  6802.   V := FileExpand(@Dir, StrPCopy(PChar(@Dir), Dir), fcCasePreserve);
  6803.   L := StrLen(PChar(@Dir));
  6804.   if (L > 3) and (PChar(@Dir)[L-1] = '\')           { To allow paths to end }
  6805.    then PChar(@Dir)[L-1] := #0;                     { with a '\' or not     }
  6806.   if DosError = deNoError
  6807.    then DosError := StrError;
  6808.   if DosError = deNoError then
  6809.    begin
  6810. {$ifdef DPMI}
  6811.      CheckDosBuf(SaveBuf, SizeOf(SaveBuf));
  6812.      StrLCopy(P, PChar(@Dir), fsDirectory);
  6813. {$endif DPMI}
  6814.      ClearRegs(Regs);
  6815.      if P[1] = ':' then
  6816.       begin
  6817.         Regs.AH := $0E;                           { DOS - Set default drive }
  6818.         Regs.DL := Ord(DosUpCase(P[0])) - Ord('A'); { 0 = A, 1 = B etc      }
  6819.         MsDos(Regs);
  6820.         Regs.AH := $19;                           { DOS - Get default drive }
  6821.         if Lo(MsDos(Regs)) <> Regs.DL then
  6822.          begin
  6823.            DosError := deInvalidDrive;
  6824.            goto Done;
  6825.          end;
  6826.         ClearRegs(Regs);
  6827.         Move(P[2], P[0], L-1);
  6828.       end;
  6829.    {$ifdef DPMI}
  6830.      Regs.DS := DosBuf.RealSeg;                   { DS:DX = @P (directory)  }
  6831.    {$else DPMI}
  6832.      Regs.DS := Seg(P);
  6833.      Regs.DX := Ofs(P);
  6834.    {$endif DPMI}
  6835.      Regs.AH := $3B;                              { DOS - Set Current Dir   }
  6836.      Regs.Flags := fCarry;
  6837.    {$ifdef LongNames}
  6838.      if V^.Attributes and vaDosLongNames <> 0
  6839.       then Regs.AX := $713B;                      { LFN - Set Current Dir   }
  6840.    {$endif LongNames}
  6841.      DosError := MsDos(Regs);
  6842.      if Regs.Flags and fCarry = 0
  6843.       then DosError := 0
  6844.       else GetExtError;
  6845.   Done:
  6846.    {$ifdef DPMI}
  6847.      RestoreDosBuf(SaveBuf, SizeOf(SaveBuf));
  6848.    {$endif DPMI}
  6849.   end;
  6850. end;
  6851.  
  6852. procedure ChangeDir(Dir: PChar);
  6853. begin
  6854.   ChDir(StrLPas(Dir, fsDirectory));
  6855. end;
  6856.  
  6857. function GetCurDrive: Char;               { Return the current drive        }
  6858. {$ifdef TurboDos}           assembler;
  6859. asm
  6860.             mov   ah,$19                  { Dos - Get Current drive         }
  6861.             int   intDos
  6862.             mov   cx,ax
  6863.             add   al,'A'
  6864. end;
  6865. {$else TurboDos}
  6866. var
  6867.   Regs: TRegisters;
  6868. begin
  6869.   ClearRegs(Regs);
  6870.   Regs.AH := $19;                         { Dos - Get Current drive         }
  6871.   GetCurDrive := Chr(MsDos(Regs) + Ord('A'));
  6872. end;
  6873. {$endif TurboDos}
  6874.  
  6875. type
  6876.   PExtDriveParamInfo = ^TExtDriveParamInfo;
  6877.   TExtDriveParamInfo = packed record       { Extended Drive Parameter Block }
  6878.     DriveNum     : Byte;       { Drive number (0 = A, 1 = B etc             }
  6879.     UnitNum      : Byte;       { Unit number within device driver           }
  6880.     BytesPerSec  : Word;       { Number of bytes in each sector             }
  6881.     MaxSecInClust: Byte;       { Highest sector number in a cluster         }
  6882.     Clust2SecShft: Byte;       { Shift count to convert clusters -> sectors }
  6883.     RsvdSects    : Word;       { Number of reserved sectors @ start of drive}
  6884.     NumFATs      : Byte;       { Number of File Allocation Tables           }
  6885.     NumRootEnts  : Word;       { Number of root directory entries           }
  6886.     FirstUserSec : Word;       { First sector containing user data          }
  6887.     MaxClustNumS : Word;       { Highest cluster number                     }
  6888.     SectPerFAT   : Byte;       { Number of sectors per File Allocation Table}
  6889.     FirstDirSec  : Word;       { First directory sector                     }
  6890.     DevDriveHdr  : Pointer;    { Pointer to device driver header            }
  6891.     MediaID      : Byte;
  6892.     ForceMediaChk: Byte;       { $FF -> force a media check                 }
  6893.     NextDPB      : DosPtr;     { Pointer to next Drive Parameter Block      }
  6894.     FreeSpcClustS: Word;       { Cluster to start looking for free spce from}
  6895.     ClustFree    : DWord;      { Number of free clusters - $FFFF = unknown  }
  6896.     FatMirrorFlgs: Word;
  6897.     FileSysInfSec: Word;
  6898.     BootBackupSec: Word;
  6899.     FirstSecNum  : DWord;      { Sector number of the first cluster         }
  6900.     MaxClustNum  : DWord;      { Highest cluster number of volume           }
  6901.     FATSecCount  : DWord;      { Number of sectors occupied by FAT          }
  6902.     RootDirClust : DWord;      { Cluster number of root directory           }
  6903.     FreeSpceClust: DWord;      { Cluster to start looking for free spce from}
  6904.   end;
  6905.  
  6906.   PFat32Info = ^TFat32Info;
  6907.   TFat32Info = record
  6908.     StrucSize      : Word;  { (ret) size of returned structure }
  6909.     StrucVer       : Word;  { (call) structure version (0000h) (ret) actual structure version (0000h) }
  6910.     SectsPerCluster: DWord; { Number of sectors per cluster (with adjustment for compression)   }
  6911.     BytesPerSector : DWord; { Number of Bytes per Sector       }
  6912.     ClustersFree   : DWord; { Number of Free Clusters          }
  6913.     ClustersTotal  : DWord; { Total number of Clusters on disk }
  6914.     SectsFreeNoCmp : DWord; { Number of physical sectors available on the drive, without adjustment for compression }
  6915.     SectsTotalNoCmp: DWord; { total number of physical sectors on the drive, without adjustment for compression }
  6916.     ClustFreeNoCmp : DWord; { Number of available allocation units, without adjustment for compression }
  6917.     ClustTotalNoCmp: DWord; { Total allocation units, without adjustment for compression }
  6918.     Reserved       : array[0..7] of Byte;
  6919.   end;
  6920.  
  6921.   PExtInfoBuf = ^TExtInfoBuf;
  6922.   TExtInfoBuf = record
  6923.     RootStr: array[0..3] of Char;
  6924.     ExtInfo: TFat32Info;
  6925.   end;
  6926.  
  6927. function GetDiskInfo(Drive: Byte;
  6928.                      var DiskInfo: TDiskInfo): Boolean;
  6929. {$ifdef LongNames}
  6930. var
  6931.   Regs: TRegisters;
  6932.   SaveBuf: TExtInfoBuf;
  6933.   V      : PVolumeInfo;
  6934.   Info   : PExtInfoBuf absolute DosBuf;
  6935. const
  6936.   RootTail: array[1..3] of Char = ':\'#0;
  6937. begin
  6938.   GetDiskInfo := false;
  6939.   ClearRegs(Regs);
  6940.   if Drive = 0
  6941.    then V := GetVolumeInfo(GetCurDrive)
  6942.    else V := GetVolumeInfo(Chr(Drive + (Ord('A') -1)));
  6943.   if V^.Attributes and vaDosLongNames <> 0
  6944.    then begin
  6945.           CheckDosBuf(SaveBuf, SizeOf(SaveBuf));
  6946.           Info^.RootStr[0] := Chr(Drive + (Ord('A') -1));
  6947.           Move(RootTail, Info^.RootStr[1], SizeOf(RootTail));
  6948.           Info^.ExtInfo.StrucVer := 0;
  6949.           Regs.DS   := DosBuf.RealSeg;
  6950.           Regs.ES   := Regs.DS;
  6951.           Regs.DI   := SizeOf(Char) * 4;
  6952.           Regs.CX   := SizeOf(TFat32Info);
  6953.           Regs.AX   := $7303;             { FAT32 - Get Extended free space }
  6954.           Regs.Flags:= fCarry;
  6955.           MsDos(Regs);
  6956.           if Regs.Flags and fCarry = 0 then
  6957.            begin
  6958.              DiskInfo.SectsPerCluster:= Info^.ExtInfo.SectsPerCluster;
  6959.              DiskInfo.BytesPerSector := Info^.ExtInfo.BytesPerSector;
  6960.              DiskInfo.ClustersFree   := Info^.ExtInfo.ClustFreeNoCmp;
  6961.              DiskInfo.ClustersTotal  := Info^.ExtInfo.ClustTotalNoCmp;
  6962.              GetDiskInfo := true;
  6963.            end;
  6964.           RestoreDosBuf(SaveBuf, SizeOf(SaveBuf));
  6965.         end
  6966.    else
  6967. {$else LongNames}
  6968.   {$ifdef TurboDos}
  6969.     assembler;
  6970.   {$else TurboDos}
  6971. var
  6972.   Regs: TRegisters;
  6973.   {$endif TurboDos}
  6974. {$endif LongNames}
  6975. {$ifdef TurboDos}
  6976.         asm
  6977.             mov   dl,[Drive]
  6978.             mov   ah,$36
  6979.             int   intDos
  6980.             les   di,[DiskInfo]
  6981.             cmp   ax,-1
  6982.             mov   [es:di+TDiskInfo.SectsPerCluster],ax
  6983.             mov   ax,false
  6984.             je    @@Exit
  6985.             mov   [es:di+TDiskInfo.BytesPerSector],cx
  6986.             mov   [es:di+TDiskInfo.ClustersFree].Word[0],bx
  6987.             mov   [es:di+TDiskInfo.ClustersFree].Word[2],ax
  6988.             mov   [es:di+TDiskInfo.ClustersTotal].Word[0],dx
  6989.             mov   [es:di+TDiskInfo.ClustersTotal].Word[2],ax
  6990.             mov   al,true
  6991.   {$ifdef LongNames}
  6992.             mov   [@Result],al
  6993.   {$endif LongNames}
  6994.     @@Exit:
  6995.         end;
  6996. {$else TurboDos}
  6997.         begin
  6998.           Regs.DL := Drive;
  6999.           Regs.AH := $36;                       { DOS - Get Free Disk Space }
  7000.           MsDos(Regs);
  7001.           if Regs.AX = $FFFF
  7002.            then Exit;
  7003.           DiskInfo.SectsPerCluster:= Regs.AX;
  7004.           DiskInfo.ClustersFree   := Regs.BX;
  7005.           DiskInfo.BytesPerSector := Regs.CX;
  7006.           DiskInfo.ClustersTotal  := Regs.DX;
  7007.           GetDiskInfo := true;
  7008.         end;
  7009. {$endif TurboDos}
  7010. {$ifdef LongNames}
  7011. end;
  7012. {$endif LongNames}
  7013.  
  7014. function DiskFree(Drive: Byte): DWord;
  7015. var
  7016.   DiskInfo: TDiskInfo;
  7017. begin
  7018.   DiskFree := -1;
  7019.   if GetDiskInfo(Drive, DiskInfo) then
  7020.    asm
  7021.     db $66; xor   ax,ax
  7022.             mov   ax,[DiskInfo.SectsPerCluster]
  7023.             mov   dx,[DiskInfo.BytesPerSector]
  7024.     db $66; mul   dx
  7025.     db $66; mov   dx,[DiskInfo.ClustersFree].Word[0]
  7026.     db $66; mul   dx
  7027.             jnc   @@1
  7028.     db $66, $B8; dd -1   { mov  eax,$FFFFFFFF }
  7029.    @@1:
  7030.     db $66; mov   word ptr [@Result],ax
  7031.    end;
  7032. end;
  7033.  
  7034. function DiskSize(Drive: Byte): DWord;
  7035. var
  7036.   DiskInfo: TDiskInfo;
  7037. begin
  7038.   DiskSize := -1;
  7039.   if GetDiskInfo(Drive, DiskInfo) then
  7040.    asm
  7041.     db $66; xor   ax,ax
  7042.             mov   ax,[DiskInfo.SectsPerCluster]
  7043.             mov   dx,[DiskInfo.BytesPerSector]
  7044.     db $66; mul   dx
  7045.     db $66; mov   dx,[DiskInfo.ClustersTotal].Word[0]
  7046.     db $66; mul   dx
  7047.             jnc   @@1
  7048.     db $66, $B8; dd -1   { mov  eax,$FFFFFFFF }
  7049.    @@1:
  7050.     db $66; mov   word ptr [@Result],ax
  7051.    end;
  7052. end;
  7053.  
  7054. {--------------------- File properties related functions -------------------}
  7055.  
  7056. procedure GetFTime(var F; var Time: Longint);
  7057. var
  7058.   SR: TSearchRec;
  7059. begin
  7060.   case TFileRec(F).Mode of
  7061.     fmClosed:
  7062.       InOutRes := 103;                      { Error = File not Open         }
  7063.     fmInput..fmInOut:
  7064.       Time := FileGetTime(TFileRec(F).Handle);
  7065.     else
  7066.       InOutRes := 102;                      { Error = File not Assigned     }
  7067.   end;
  7068. end;
  7069.  
  7070. procedure SetFTime(var F; Time: Longint);
  7071. begin
  7072.   case TFileRec(F).Mode of
  7073.     fmClosed:
  7074.       InOutRes := 103;                      { Error = File not Open         }
  7075.     fmInput..fmInOut:
  7076.       FileSetTime(TFileRec(F).Handle, Time);
  7077.     else
  7078.       InOutRes := 102;                      { Error = File not Assigned     }
  7079.   end;
  7080. end;
  7081.  
  7082. procedure CheckForLfnDrv; assembler;    { Inputs : EAX = PChar to file name }
  7083. asm                                     { Outputs: ES:DI = @TVolumeInfo     }
  7084.     db $66; push  ax                    {          ZF = 0 if LFN capable    }
  7085.             call  GetVolumeOfStr
  7086.             mov   es,dx
  7087.             mov   di,ax
  7088.             or    dx,ax
  7089.             jz    @@Exit                { Invalid drive, ZF = 1, ES:DI = nil}
  7090.             test  [es:di].TVolumeInfo.Attributes,vaDosLongNames
  7091. @@Exit:
  7092. end;
  7093.  
  7094. type
  7095.   PWin95FileInfo = ^TWin95FileInfo;
  7096.   TWin95FileInfo = packed record
  7097.     Attributes: DWord;
  7098.     CTimeLo   : DWord;
  7099.     CTimeHi   : DWord;
  7100.     ATimeLo   : DWord;
  7101.     ATimeHi   : DWord;
  7102.     WTimeLo   : DWord;
  7103.     WTimeHi   : DWord;
  7104.     VolSerNum : DWord;
  7105.     FSizeHi   : DWord;
  7106.     FSizeLo   : DWord;
  7107.     LinkCnt   : DWord;
  7108.     FileID_Hi : DWord;
  7109.     FileID_Lo : DWord;
  7110.   end;
  7111.  
  7112. function FileGetSetAttr(PathName: PChar; Attr: Word; Op: TAttrOp): Word;
  7113. {$ifdef TurboLong} assembler;
  7114. asm
  7115.             push  ds                        { Save global DS                }
  7116.   {$ifdef LongNames}
  7117.     db $66; mov   ax,PathName.Word[0]
  7118.             call  CheckForLfnDrv
  7119.             mov   ax,$7143                  { LFN - Get/Set Ext file attribs}
  7120.             mov   bl,[Op]                   { BL  = Get file attributes     }
  7121.             jnz   @@LFN                     {     - or Set File Attributes  }
  7122.   {$endif LongNames}
  7123.             mov   ah,$43                    { DOS - Get File Attributes     }
  7124.             mov   al,[Op]                   {     - or Set File Attributes  }
  7125.  
  7126. @@LFN:      lds   dx,[PathName]             { DS:DX = address of file name  }
  7127.             mov   cx,[Attr]                 { For Set file attribute        }
  7128.             stc
  7129.             int   intDos
  7130.             pop   ds
  7131.             mov   bx,ax
  7132.             mov   bx,deNoError
  7133.             jnc   @@Exit
  7134.             call  GetExtError               { Extended error code => AX & BX}
  7135.             xor   cx,cx
  7136. @@Exit:     mov   [DosError],bx
  7137.             mov   ax,cx                     { Return Attributes for GetFAttr}
  7138.             nop
  7139. end;
  7140. {$else TurboLong}
  7141. var
  7142.   Regs   : TRegisters;
  7143.   {$ifdef DPMI}
  7144.   Name   : PChar absolute DosBuf;
  7145.   SaveBuf: TPathName;
  7146.   {$else DPMI}
  7147.   Name   : PChar absolute PathName;
  7148.   {$endif DPMI}
  7149. begin
  7150.   ClearRegs(Regs);
  7151.   Regs.AX := $4300 + Ord(Op);               { DOS - Get file attributes     }
  7152.   {$ifdef DPMI}
  7153.   CheckDosBuf(SaveBuf, SizeOf(SaveBuf));
  7154.   Regs.DS := DosBuf.RealSeg;                { or - Get file attributes      }
  7155.   StrLCopy(Name, PathName, High(SaveBuf)+1);{ BL = 0 = Get file attributes  }
  7156.   DosError := StrError;
  7157.   if DosError = deNoError then
  7158.   {$else DPMI}
  7159.   Regs.DS := PtrRec(PathName).Seg;
  7160.   Regs.DX := PtrRec(PathName).Ofs;
  7161.   {$endif DPMI}
  7162.   begin
  7163.   {$ifdef LongNames}
  7164.     if GetVolumeFromPath(Name)^.Attributes and vaDosLongNames <> 0 then
  7165.      begin
  7166.        Regs.AX := $7143;                    { LFN - Get/Set Ext file attribs}
  7167.        Regs.BX := Ord(Op);
  7168.      end;
  7169.   {$endif LongNames}
  7170.     Regs.Flags := fCarry;
  7171.     Regs.CX := Attr;                        { Set CX for Set File Attributes}
  7172.     DosError := MsDos(Regs);
  7173.     if Regs.Flags and fCarry = 0
  7174.      then DosError := 0
  7175.      else begin
  7176.             GetExtError;
  7177.             Regs.CX := 0;
  7178.           end;
  7179.   end;
  7180.   {$ifdef DPMI}
  7181.   RestoreDosBuf(SaveBuf, SizeOf(SaveBuf));
  7182.   {$endif DPMI}
  7183.   FileGetSetAttr := Regs.CX;                { For Get File attributes       }
  7184. end;
  7185. {$endif TurboLong}
  7186.  
  7187. procedure GetFAttr(var F; var Attr: Word);
  7188. var
  7189.   TF: TFileRec absolute F;
  7190. begin
  7191.   case TFileRec(F).Mode of                  { Make sure F is a File or Text }
  7192.     fmClosed..fmInOut:                      { variable. Let the O/S decide  }
  7193. {$ifdef LongNames}                          { if an error occurs on an open }
  7194.       Attr := FileGetSetAttr(TF.Name, 0, faGet);     { file, rather than    }
  7195. {$else LongNames}                                    { just assuming it will}
  7196.       Attr := FileGetSetAttr(@TF.Name, 0, faGet);
  7197. {$endif LongNames}
  7198.     else
  7199.       InOutRes := 102;                      { Error = File not Assigned     }
  7200.   end;
  7201. end;
  7202.  
  7203. procedure SetFAttr(var F; Attr: Word);
  7204. var
  7205.   TF: TFileRec absolute F;
  7206. begin
  7207.   case TFileRec(F).Mode of                  { Make sure F is a File or Text }
  7208.     fmClosed..fmInOut:                      { variable. Let the O/S decide  }
  7209. {$ifdef LongNames}                          { if an error occurs on an open }
  7210.       FileGetSetAttr(TF.Name, Attr, faSet);          { file, rather than    }
  7211. {$else LongNames}                                    { just assuming it will}
  7212.       FileGetSetAttr(@TF.Name, Attr, faSet);
  7213. {$endif LongNames}
  7214.     else
  7215.       InOutRes := 102;                      { Error = File not Assigned     }
  7216.   end;
  7217. end;
  7218.  
  7219. procedure GetFSize(var F; var Size: Longint);
  7220. var
  7221.   SR  : TSearchRec;
  7222. {$ifdef Windows}
  7223.   Name: TPathName;
  7224. {$else Windows}
  7225.   Name: TPathStr;
  7226. {$endif Window}
  7227. begin
  7228.   Size := -1;
  7229.   case TFileRec(F).Mode of                  { Make sure F is a File or Text }
  7230.     fmClosed:                               { variable                      }
  7231.       begin
  7232. {$ifdef Windows}
  7233.         if FindFirst(TFileRec(F).Name, faAnyFile, SR) then
  7234. {$else Windows}
  7235.   {$ifdef LongNames}
  7236.         Name := NullToPas(TFileRec(F).Name);
  7237.   {$else LongNames}
  7238.         Name := NullToPas(@TFileRec(F).Name);
  7239.   {$endif LongNames}
  7240.         if FindFirst(Name, faAnyFile, SR) then
  7241. {$endif Windows}
  7242.          begin
  7243.            Size := SR.Size;
  7244.            FindClose(SR);
  7245.          end;
  7246.       end;
  7247.     fmInput..fmInOut:
  7248.       Size := FileSize(TFileRec(F).Handle);
  7249.     else
  7250.       InOutRes := 102;                      { Error = File not Assigned     }
  7251.   end;
  7252. end;
  7253.  
  7254. procedure StdOutName; assembler;
  7255. asm  db 6,'StdOut'; db 0 end;
  7256. procedure StdInName; assembler;
  7257. asm  db 5,'StdIn'; db 0 end;
  7258. procedure StdErrName; assembler;
  7259. asm  db 6,'StdErr'; db 0 end;
  7260. procedure StdPrnName; assembler;
  7261. asm  db 6,'StdPrn'; db 0 end;
  7262.  
  7263. const
  7264.   StdNames: array[1..4] of NearPtr = (
  7265.     Ofs(StdOutName),Ofs(StdInName),Ofs(StdErrName),Ofs(StdPrnName));
  7266.  
  7267. function GetFName(var F): TPathStr;
  7268. var
  7269.   FR: TFileRec absolute F;
  7270. begin
  7271.   case FR.Mode of
  7272.     fmClosed..fmInOut:
  7273.       begin
  7274.         if FR.Handle <= 4
  7275.          then GetFName := PPathStr(Ptr(Seg(StdOutName), StdNames[FR.Handle]))^
  7276.          else begin
  7277. {$ifdef LongNames}
  7278.                 GetFName := StrLPas(FR.Name, High(TPathStr));
  7279. {$else LongNames}
  7280.                 GetFName := StrPas(@FR.Name);
  7281. {$endif LongNames}
  7282.                 InOutRes := StrError;
  7283.               end;
  7284.       end
  7285.     else
  7286.       begin
  7287.         InOutRes := 102;                    { File not assigned error       }
  7288.         GetFName := '';
  7289.       end;
  7290.   end;
  7291. end;
  7292.  
  7293. function GetFileName(var F): PChar;
  7294. var
  7295.   FR: TFileRec absolute F;
  7296. begin
  7297.   case FR.Mode of
  7298.     fmClosed..fmInOut:
  7299.       begin
  7300.         if FR.Handle <= 4
  7301.          then GetFileName := PChar(Ptr(Seg(StdOutName), StdNames[FR.Handle]+1))
  7302.          else
  7303. {$ifdef LongNames}
  7304.               GetFileName := FR.Name;
  7305. {$else LongNames}
  7306.               GetFileName := @FR.Name;
  7307. {$endif LongNames}
  7308.         InOutRes := 0;
  7309.       end
  7310.     else
  7311.       begin
  7312.         InOutRes := 102;                    { File not assigned error       }
  7313.         GetFileName := nil;
  7314.       end;
  7315.   end;
  7316. end;
  7317.  
  7318. procedure SetFileCase(CaseRule: TFileCase);
  7319. begin
  7320.   FileCase := CaseRule;
  7321. end;
  7322.  
  7323. procedure UnpackTime(Time: Longint; var DT: TDateTime); assembler;
  7324. asm
  7325.             les   di,[DT]
  7326.             mov   ax,[LongRec(Time).Hi]     { Packed date  }
  7327.             mov   dx,ax
  7328.             shr   ax,9
  7329.             cld
  7330.             add   ax,1980
  7331.             stosw                           { DT.Year      }
  7332.             mov   ax,dx
  7333.             shr   ax,5
  7334.             and   ax,$000F
  7335.             stosw                           { DT.Month     }
  7336.             mov   ax,dx
  7337.             and   ax,$1F
  7338.             stosw                           { DT.Day       }
  7339.  
  7340.             mov   ax,[LongRec(Time).Lo]     { Packed time  }
  7341.             mov   dx,ax
  7342.             shr   ax,11
  7343.             stosw                           { DT.Hour      }
  7344.             mov   ax,dx
  7345.             shr   ax,5
  7346.             and   ax,$3F
  7347.             stosw                           { DT.Minute    }
  7348.             mov   ax,dx
  7349.             and   ax,$1F
  7350.             shl   ax,1
  7351.             stosw                           { DT.Second    }
  7352. end;
  7353.  
  7354. procedure PackTime(const DT: TDateTime; var Time: Longint); assembler;
  7355. asm
  7356.             push  ds
  7357.             lds   si,[DT]
  7358.             cld
  7359.             les   di,[Time]
  7360.  
  7361.             lodsw                           { DT.Year      }
  7362.             sub   ax,1980
  7363.             shl   ax,9
  7364.             mov   dx,ax
  7365.             lodsw                           { DT.Month     }
  7366.             shl   ax,5
  7367.             add   dx,ax
  7368.             lodsw                           { DT.Day       }
  7369.             add   ax,dx
  7370.     db $66; shl   ax,16                     { Packed Date  }
  7371.  
  7372.             lodsw                           { DT.Hour      }
  7373.             shl   ax,11
  7374.             mov   cx,ax
  7375.             lodsw                           { DT.Minute    }
  7376.             shl   ax,5
  7377.             add   cx,ax
  7378.             lodsw                           { DT.Second    }
  7379.             shr   ax,1
  7380.             add   ax,cx
  7381.             pop   ds
  7382.     db $66; stosw                           { Store Time/Date}
  7383. end;
  7384.  
  7385. {------------------- File/Directory name related functions -----------------}
  7386.  
  7387. procedure DelDirSep(var Dir: TDirStr);
  7388. begin
  7389.   if Dir[Length(Dir)] = '\'
  7390.    then Dec(Dir[0]);
  7391. end;
  7392.  
  7393. procedure DelDirSepStr(Dir: PChar);
  7394. var
  7395.   Len: Word;
  7396. begin
  7397.   Len := MaxWord(StrLen(Dir)-1, 0);
  7398.   if Dir[Len] = '\'
  7399.    then Dir[Len] := #0;
  7400. end;
  7401.  
  7402. procedure AddDirSep(var Dir: TDirStr);
  7403. begin
  7404.   if Dir[Length(Dir)] <> '\'
  7405.    then Dir := Dir + '\';
  7406. end;
  7407.  
  7408. procedure AddDirSepStr(Dir: PChar);
  7409. var
  7410.   Len: Word;
  7411. begin
  7412.   Len := StrLen(Dir);
  7413.   if (Len > 0) and (Dir[Len-1] <> '\') then
  7414.    begin
  7415.      Dir[Len] := '\';
  7416.      Dir[Len+1] := #0;
  7417.    end;
  7418. end;
  7419.  
  7420. function IsRootDir(const S: TPathStr): Boolean;
  7421. var
  7422.   L: Word;
  7423. begin
  7424.   L := Length(S);
  7425.   IsRootDir := (L - 2 <= 1) and (S[2] = ':') and
  7426.                ((L = 2) or (S[3] = '\')) and DriveValid(S[1]);
  7427. end;
  7428.  
  7429. function IsRootDirStr(S: PChar): Boolean;
  7430. var
  7431.   L: Word;
  7432. begin
  7433.   L := StrLen(S);
  7434.   IsRootDirStr := (L - 2 <= 1) and (S[1] = ':') and
  7435.                   ((L = 2) or (S[2] = '\')) and DriveValid(S[0]);
  7436. end;
  7437.  
  7438. function IsDirectory(S: TPathStr): Boolean;
  7439. var
  7440.   SR: TSearchRec;
  7441. begin
  7442.   IsDirectory := false;
  7443.   if S = ''
  7444.    then Exit;
  7445.   IsDirectory := true;
  7446.   if not IsRootDir(S) then
  7447.    begin
  7448.      {$V-} DelDirSep(S); {$V+}
  7449. {$ifdef Windows}
  7450.      PasToNull(S, @S)
  7451.      FindFirst(@S, faReqDirectory + faAnyFile, SR);
  7452. {$else Windows}
  7453.      FindFirst(S, faReqDirectory + faAnyFile, SR);
  7454. {$endif Windows}
  7455.      FindClose(SR);
  7456.      IsDirectory := IOResult = 0;
  7457.    end;
  7458. end;
  7459.  
  7460. function IsDirectoryStr(S: PChar): Boolean;
  7461. var
  7462.   SR: TSearchRec;
  7463.   P : array[0..fsPathName] of Char;
  7464. begin
  7465.   IsDirectoryStr := false;
  7466.   if (S = nil) or (S^ = #0)
  7467.    then Exit;
  7468.   IsDirectoryStr := true;
  7469.   if not IsRootDirStr(S) then
  7470.    begin
  7471.      StrLCopy(@P, S, fsPathName);
  7472.      DosError := StrError;
  7473.      if DosError = deNoError then
  7474.       begin
  7475.         DelDirSepStr(@P);
  7476. {$ifdef Windows}
  7477.         FindFirst(@P, faReqDirectory + faAnyFile, SR);
  7478. {$else Windows}
  7479.         FindFirstStr(@P, faReqDirectory + faAnyFile, SR);
  7480. {$endif Windows}
  7481.         FindClose(SR);
  7482.       end;
  7483.      IsDirectoryStr := IOResult = 0;
  7484.    end;
  7485. end;
  7486.  
  7487. procedure DoDirOpStr(Dir: PChar; DosOp: Byte);
  7488. var
  7489.   Regs   : TRegisters;
  7490.   P      : PChar absolute DosBuf;
  7491.   SaveBuf: TNetPath;
  7492.   Path   : TPathNet;
  7493.   V      : PVolumeInfo;
  7494. label
  7495.   Done;
  7496. begin
  7497.   CheckDosBuf(SaveBuf, SizeOf(SaveBuf));
  7498.   ClearRegs(Regs);
  7499.   StrLCopy(@Path, Dir, fsNetPath);
  7500.   if StrError <> 0 then
  7501.    begin
  7502.      DosError := StrError;
  7503.      goto Done;
  7504.    end;
  7505. {$ifdef Windows}
  7506.   AnsiToOem(@Path, @Path);
  7507. {$endif Windows}
  7508.   V := FileExpand(@Path, @Path, fcCasePreserve);
  7509.   if DosError <> deNoError
  7510.    then goto Done;
  7511.   StrCopy(P, @Path);
  7512.   Regs.DS := DosBuf.RealSeg;
  7513.   Regs.AH := DosOp;
  7514.   Regs.Flags := fCarry;
  7515. {$ifdef LongNames}
  7516.   if V^.Attributes and vaDosLongNames <> 0
  7517.    then Regs.AX := $7100 + DosOp;             { LFN Create/Remove Directory }
  7518. {$endif LongNames}
  7519.   DosError := MsDos(Regs);
  7520.   if Regs.Flags and fCarry = 0
  7521.    then DosError := 0
  7522.    else GetExtError;
  7523. Done:
  7524.   RestoreDosBuf(SaveBuf, SizeOf(SaveBuf));
  7525. end;
  7526.  
  7527. procedure CreateDir(Dir: PChar);
  7528. begin
  7529.   DoDirOpStr(Dir, $39); { DOS - Create Directory }
  7530. end;
  7531.  
  7532. procedure RemoveDir(Dir: PChar);
  7533. begin
  7534.   DoDirOpStr(Dir, $3A); { DOS - Remove Directory }
  7535. end;
  7536.  
  7537. type
  7538.   PDosSearch = ^TDosSearch;
  7539.   TDosSearch = packed record
  7540.     Fill   : packed array[1..21] of Byte;      {00..20}
  7541.     Attr   : Byte;                             {21..21}
  7542.     Time   : Longint;                          {22..25}
  7543.     Size   : Longint;                          {26..29}
  7544.     Name   : array[0..High(TDosName)] of Char; {30..41}
  7545.   end;
  7546.  
  7547.   PLongSearch = ^TLongSearch;
  7548. {$ifdef LongNames}
  7549.   TLongSearch = packed record
  7550.     Attr   : Longint;                      {000..003}
  7551.     CTime  : Longint;                      {004..007}
  7552.     CTimeH : Longint;                      {008..011}
  7553.     ATime  : Longint;                      {012..015}
  7554.     ATimeH : Longint;                      {016..019}
  7555.     Time   : Longint;                      {020..023}
  7556.     TimeH  : Longint;                      {024..027}
  7557.     SizeH  : Longint;                      {028..031}
  7558.     Size   : Longint;                      {032..035}
  7559.     Rsvd   : packed array[0..7] of Byte;   {036..043}
  7560.     Name   : packed array[0..259] of Char; {044..303}
  7561.     DosName: packed array[0..13] of Char;  {304..317}
  7562.   end;
  7563. {$else LongNames}
  7564.   TLongSearch = TDosSearch;
  7565. {$endif LongNames}
  7566.  
  7567.   PSearchBuf = ^TSearchBuf;
  7568.   TSearchBuf = packed record
  7569.     SR  : TLongSearch;
  7570.     Name: TPathName;
  7571.   end;
  7572.  
  7573.  PDosCdEntry = ^TDosCdEntry;
  7574.  TDosCdEntry = record
  7575.    EntryLen    : Byte;
  7576.    XarLen      : Byte;
  7577.    IntelLBN    : DWord;
  7578.    MotLBN      : DWord;
  7579.    IntelFileLen: DWord;
  7580.    MotFileLen  : DWord;
  7581.    Reserved    : array[0..7] of Byte;
  7582.    InterSize   : Byte;
  7583.    InterSkip   : Byte;
  7584.    IntelVolNum : Word;
  7585.    MotVolNum   : Word;
  7586.    FileName    : String[223];
  7587.  end;
  7588.  
  7589.  PDosCdRom = ^TDosCDRom;
  7590.  TDosCdRom = record
  7591.    Path : array[0..fsDosPath] of Char;
  7592.    Entry: TDosCDEntry;
  7593.  end;
  7594.  
  7595. procedure ConvertSearchRec(var SR: TSearchRec);
  7596. var
  7597.   L: PLongSearch absolute DosBuf;    { Converts a Win95 style TLongSearch   }
  7598.   D: PDosSearch absolute DosBuf;     { into a TP-style TSearchRec. Also     }
  7599.   IsDosName: Boolean;                { converts the filname case if compiled}
  7600.   Padder   : Boolean;                { for LFN support, and FileCase is set }
  7601. begin                                { to fnDosLower or fnDos1stCapital     }
  7602. {$ifdef LongNames}
  7603.   if SR.VolAttribs and vaDosLongNames <> 0
  7604.    then begin
  7605.           SR.Time := L^.Time;
  7606.           SR.Size := L^.Size;
  7607.           SR.Attr := WordRec(LongRec(L^.Attr).Lo).Lo;
  7608.           Move(L^.Name, SR.Name, StrLen(@L^.Name)+1);
  7609.           IsDosName := (SR.VolAttribs and vaCaseSensitive = 0) and
  7610.                        ((L^.DosName[0] = #0) or
  7611.                         (StrComp(@L^.DosName, @L^.Name) = 0));
  7612.         end
  7613.    else
  7614. {$endif LongNames}
  7615.         begin
  7616.           Move(D^, SR, SizeOf(TDosSearch));
  7617.           IsDosName := true;
  7618.         end;
  7619.  
  7620.   { If IsDosName is true, then we have an all-uppercase 8.3 name in SR.Name }
  7621.  
  7622.   if (SR.VolAttribs and vaCaseSensitive = 0) and (FileCase <> fnPreserve) then
  7623.    case FileCase of
  7624.      fnLowerCase:
  7625.        StrLower(@SR.Name);
  7626.      fnUpperCase:
  7627.        StrUpper(@SR.Name);
  7628.      else
  7629. {$ifdef LongNames}
  7630.        if IsDosName then
  7631. {$endif LongNames}
  7632.         if FileCase = fnDos1stUpper
  7633.          then StrLower(@SR.Name[1])                 { Capitalize 1st letter }
  7634.          else StrLower(@SR.Name);
  7635.    end;
  7636. {$ifdef Windows}
  7637.        OemToAnsi(@SR.Name, @SR.Name); { SR.Name is array of Char in Windows }
  7638. {$else Windows}
  7639.        SR.Name := NullToPas(@SR.Name);{ SR.Name is Pascal string in DOS/DPMI}
  7640. {$endif Windows}
  7641. end;
  7642.  
  7643. function FindNext(var SR: TSearchRec): Boolean;
  7644. var
  7645.   Regs: TRegisters;
  7646.   S   : PDosSearch absolute DosBuf;
  7647.   L   : PLongSearch absolute DosBuf;
  7648. begin
  7649.   FindNext := false;
  7650.   ClearRegs(Regs);
  7651. {$ifdef LongNames}
  7652.   if SR.VolAttribs and vaDosLongNames <> 0
  7653.    then repeat                         { Win9x is buggy, so we have to to   }
  7654.           Regs.BX := SR.Handle;        { check the returned attribs ourself }
  7655.           Regs.SI := 1;                { Return MS-DOS style time/date      }
  7656.           Regs.AX := $714F;            { Dos7.x - Find Next Matching file   }
  7657.           Regs.ES := DosBuf.RealSeg;
  7658.           DosError := MsDos(Regs);     { LongFindNext                       }
  7659.           if Regs.Flags and fCarry <> 0 then { carry set indicates an error }
  7660.            begin
  7661.              FindClose(SR);            { Auto close the file search on error}
  7662.              Exit;
  7663.            end;
  7664.         until WordRec(LongRec(L^.Attr).Lo).Lo and SR.AttrMask = SR.AttrMask
  7665.    else
  7666. {$endif LongNames}
  7667.         begin
  7668.           Regs.DS := DosBuf.RealSeg;
  7669.           Move(SR, S^, SizeOf(TDosSearch));    { Copy last SearchRec to DTA }
  7670.           repeat
  7671.             Regs.AH := $4F;            { DOS - Find Next matching filespec  }
  7672.             DosError := MsDos(Regs);   { FindNext                           }
  7673.             if Regs.Flags and fCarry <> 0  { If carry is set then an error  }
  7674.              then Exit;                    { occured. No need to FindClose  }
  7675.           until S^.Attr and SR.AttrMask = SR.AttrMask;
  7676.         end;
  7677.   ConvertSearchRec(SR);                { Convert to TSearchRec and Name case}
  7678.   DosError := 0;
  7679.   FindNext := true;
  7680. end;
  7681.  
  7682. {$ifndef Windows}
  7683. function FindFirst(Path: TPathStr; Attr: Word; var SR: TSearchRec): Boolean;
  7684. var
  7685.   Regs   : TRegisters;
  7686.   SrchBuf: PSearchBuf absolute DosBuf;
  7687.   S      : PDosSearch absolute DosBuf;
  7688.   SaveBuf: TSearchBuf;
  7689.   V      : PVolumeInfo;
  7690. label
  7691.   Error;
  7692. begin
  7693.   FindFirst := false;
  7694.   FillChar(SR, SizeOf(SR), 0);
  7695.   CheckDosBuf(SaveBuf, SizeOf(SaveBuf));
  7696.  
  7697.   { Add the "must have" file attributes to the "can have" file attributes }
  7698.  
  7699.   WordRec(Attr).Lo := WordRec(Attr).Lo or WordRec(Attr).Hi;
  7700.  
  7701.   PasToNull(Path, @SrchBuf^.Name);     { ASCIIZ @DosBuf:SizeOf(TLongName)   }
  7702.  
  7703.   V := GetVolumeFromPath(@SrchBuf^.Name);
  7704.   if V = nil
  7705.    then goto Error;
  7706.   SR.VolAttribs := V^.Attributes;
  7707.  
  7708.   ClearRegs(Regs);
  7709.   Regs.DS := DosBuf.RealSeg;
  7710.  
  7711.   {$ifdef LongNames}
  7712.   if SR.VolAttribs and vaDosLongNames <> 0
  7713.    then begin
  7714.           Regs.DX := SizeOf(TLongSearch); { DS:DX = @ASCIIZ filter string   }
  7715.           Regs.CX := Attr;
  7716.           Regs.ES := DosBuf.RealSeg;   { ES:DI := @TSearchRec               }
  7717.           Regs.Flags := fCarry;        { Set CF for function supprt checking}
  7718.           Regs.SI := 1;                { Use MsDos date/time format         }
  7719.           Regs.AX := $714E;            { DOS 7.x - Find First matching file }
  7720.         end
  7721.    else
  7722.   {$endif LongNames}
  7723.         begin                          { Set Disk Transfer Address to DosBuf}
  7724.           if Length(Path) > High(TDosPath) then { Paths are limited to 79   }
  7725.            begin                                { chars without LFN         }
  7726.              DosError := dePathTooLong;
  7727.              goto Error;
  7728.            end;
  7729.           ClearRegs(Regs);
  7730.           Regs.DS := DosBuf.RealSeg;
  7731.           Regs.DX := SizeOf(TLongSearch);  { DS:DX = @ASCIIZ filter string  }
  7732.           Regs.CX := Attr;
  7733.           Regs.AH := $4E;              { AH = Dos Function (FindFirstFile)  }
  7734.         end;
  7735.   DosError := MsDos(Regs);             { FindFirst or FindFirstLong         }
  7736.   if Regs.Flags and fCarry = 0 then    { Carry set indicates an error, but  }
  7737.    begin                               { no need to FindClose.              }
  7738.  
  7739. { WIN95 BUG: Network drives on Direct Cable ignore the faReqXXXX flags.     }
  7740. {            ie LFN $714E on network drives only works like DOS $4E         }
  7741. {            This means TSearchRec always needs an AttrMask and FindFirst & }
  7742. {            FindNext always have to check the returned attributes.         }
  7743.  
  7744.      DosError := 0;
  7745.      ConvertSearchRec(SR);
  7746.   {$ifdef LongNames}
  7747.      SR.Handle := Regs.AX;             { Set FindFirst handle if successful }
  7748.   {$endif LongNames}
  7749.      SR.AttrMask:= WordRec(Attr).Hi;   { Implement Win95-style "must have"s }
  7750.      if (SR.Attr and SR.AttrMask <> SR.AttrMask)
  7751.       then FindNext(SR);
  7752.    end;
  7753. Error:
  7754.   RestoreDosBuf(SaveBuf, SizeOf(SaveBuf));
  7755.   FindFirst := DosError = 0;
  7756. end;
  7757.  
  7758. function FindFirstStr(Path: PChar; Attr: Word; var SR: TSearchRec): Boolean;
  7759. {$else !Windows}
  7760. function FindFirst(Path: PChar; Attr: Word; var SR: TSearchRec): Boolean;
  7761. {$endif !Windows}
  7762. var
  7763.   Regs   : TRegisters;
  7764.   SrchBuf: PSearchBuf absolute DosBuf;
  7765.   S      : PDosSearch absolute DosBuf;
  7766.   V      : PVolumeInfo;
  7767.   SaveBuf: TSearchBuf;
  7768. label
  7769.   Error;
  7770. begin
  7771. {$ifdef Windows}
  7772.   FindFirst := false;
  7773. {$else Windows}
  7774.   FindFirstStr := false;
  7775. {$endif Windows}
  7776.   FillChar(SR, SizeOf(SR), 0);
  7777.   CheckDosBuf(SaveBuf, SizeOf(SaveBuf));
  7778.  
  7779.   { Add the "must have" file attributes to the "can have" file attributes }
  7780.  
  7781.   WordRec(Attr).Lo := WordRec(Attr).Lo or WordRec(Attr).Hi;
  7782.  
  7783.   { Copy Path into Buf.Name and use it to get the volume info }
  7784.  
  7785.   StrLCopy(@SrchBuf^.Name, Path, SizeOf(TPathName));
  7786.   DosError := StrError;
  7787.   if DosError <> 0
  7788.    then goto Error;
  7789.   V := GetVolumeFromPath(@SrchBuf^.Name);
  7790.   if V = nil
  7791.    then goto Error;
  7792.  
  7793.   SR.VolAttribs := V^.Attributes;
  7794.   SR.Handle := 0;
  7795.  
  7796.   ClearRegs(Regs);
  7797.   Regs.DS := DosBuf.RealSeg;
  7798.  
  7799. {$ifdef LongNames}
  7800.   if V^.Attributes and vaDosLongNames <> 0
  7801.    then begin
  7802.           Regs.DX := SizeOf(TLongSearch); { DS:DX = @ASCIIZ filter string   }
  7803.           Regs.CX := Attr;
  7804.           Regs.ES := DosBuf.RealSeg;   { ES:DI := @TSearchRec               }
  7805.           Regs.Flags := fCarry;        { Set CF for function supprt checking}
  7806.           Regs.SI := 1;                { Use MsDos date/time format         }
  7807.           Regs.AX := $714E;            { DOS 7.x - Find First matching file }
  7808.         end
  7809.    else
  7810. {$endif LongNames}
  7811.         begin                          { Set Disk Transfer Address to DosBuf}
  7812.           if StrLen(@SrchBuf^.Name) > fsDosPath then { Paths are limited to }
  7813.            begin                                     { 79 chars without LFN }
  7814.              DosError := dePathTooLong;
  7815.              goto Error;
  7816.            end;
  7817.           ClearRegs(Regs);
  7818.           Regs.DS := DosBuf.RealSeg;
  7819.           Regs.DX := SizeOf(TLongSearch);  { DS:DX = @ASCIIZ filter string  }
  7820.           Regs.CX := Attr;
  7821.           Regs.AH := $4E;              { AH = Dos Function (FindFirstFile)  }
  7822.         end;
  7823.  
  7824.   DosError := MsDos(Regs);             { FindFirst or FindFirstLong         }
  7825.   if Regs.Flags and fCarry = 0 then    { Carry set indicates an error, so   }
  7826.    begin                               { no need to FindClose.              }
  7827.      DosError := 0;
  7828.      ConvertSearchRec(SR);
  7829.  
  7830. {$ifdef LongNames}
  7831.      SR.Handle := Regs.AX;             { Set FindFirst handle if successful }
  7832. {$endif LongNames}
  7833.      SR.AttrMask:= WordRec(Attr).Hi;   { Implement Win95-style "must have"'s}
  7834.      if (SR.Attr and SR.AttrMask <> SR.AttrMask)
  7835.       then FindNext(SR);
  7836.    end;
  7837. Error:
  7838.   RestoreDosBuf(SaveBuf, SizeOf(SaveBuf));
  7839. {$ifdef Windows}
  7840.   FindFirst := DosError = 0;
  7841. {$else Windows}
  7842.   FindFirstStr := DosError = 0;
  7843. {$endif Windows}
  7844. end;
  7845.  
  7846. {$ifdef LongNames}
  7847. procedure FindClose(var SR: TSearchRec);
  7848. var
  7849.   Regs: TRegisters;
  7850. begin
  7851.   if (SR.VolAttribs and vaDosLongNames <> 0) and (SR.Handle <> 0) then
  7852.    begin
  7853.      ClearRegs(Regs);
  7854.      Regs.AX := $71A1;
  7855.      Regs.BX := SR.Handle;
  7856.      MsDos(Regs);
  7857.      SR.Handle := 0;
  7858.    end;
  7859. end;
  7860. {$endif LongNames}
  7861.  
  7862. procedure ExpandPath; near; assembler; { NOT USED DS:SI = @Source ES:DI = @Target    }
  7863. var                                    { CX = Length(Source)                }
  7864.   Result: TPathName;                   { AX = Max length of return string   }
  7865. asm
  7866.             push  ds                   { Save callers DS register           }
  7867.             push  es                   { Save address of Target string      }
  7868.             push  di
  7869.             push  ax                   { Save MaxLen argument               }
  7870.  
  7871.             push  cx                   { Convert forslashes to backslashes  }
  7872.             push  ds
  7873.             push  si
  7874.             call  SlashConvert
  7875.  
  7876.             push  ss
  7877.             lea   di,[Result]
  7878.             pop   es
  7879.             add   cx,si                { DS:CX = @End of source path + 1    }
  7880.             lodsw                      { if AH = ":" then AL = drive name   }
  7881.             cmp   si,cx                { past end of source path?           }
  7882.             ja    @@GetDrive           { Yes, so get current drive          }
  7883.             cmp   ah,':'               { AL represent drive letter?         }
  7884.             jne   @@GetDrive           { No, so get current drive           }
  7885.             cmp   al,'a'               { Validate drive letter              }
  7886.             jb    @@2                  { uppcase drive letter on invalid    }
  7887.             cmp   al,'z'
  7888.             ja    @@2                  { Invalid drive letter               }
  7889.             sub   al,'a' - 'A'         { Drive letter is always uppercase   }
  7890.             jmp   @@2
  7891.  
  7892. @@GetDrive: sub   si,2                 { Go back 2 source path characters   }
  7893.             push  ds
  7894.             push  cx
  7895.             push  es
  7896.             mov   cx,seg @Data
  7897.             push  di
  7898.             push  si
  7899.             mov   ds,cx
  7900.             call  GetCurDrive          { Get the current drive letter in AL }
  7901.             pop   si
  7902.             pop   di
  7903.             pop   es
  7904.             pop   cx
  7905.             pop   ds
  7906.             mov   ah,':'
  7907.  
  7908. @@2:        stosw                      { Store first 2 result path chars    }
  7909.             cmp   si,cx                { Reached end of source path string? }
  7910.             je    @@GetDir             { Yes, so get current directory      }
  7911.             cmp   byte ptr [si],'\'    { Start from the root directory?     }
  7912.             je    @@3                  { Yes.                               }
  7913.  
  7914. @@GetDir:   sub   al,'A'-1             { Path is relative to current dir.   }
  7915.             sub   di,2                 { Remove 'D:' from @Result because   }
  7916.             push  si                   { GetDir will set the drive as well  }
  7917.             push  cx                   { as the current directory           }
  7918.             push  ds
  7919.  
  7920.             mov   cx,seg @Data
  7921.             push  ax                   { Drive number argument              }
  7922.             push  es                   { Directory PString argument         }
  7923.             push  di
  7924.             mov   ds,cx
  7925.             push  fsPathName           { Max string length argument         }
  7926.             push  cs
  7927.             call  near ptr LfnGetDir
  7928.             push  ss
  7929.             lea   si,[Result]          { Convert Pascal string to ASCII-Z   }
  7930.             pop   ds
  7931.             xor   cx,cx
  7932.             push  ss
  7933.             lea   di,[Result]
  7934.             xor   ax,ax
  7935.             pop   es
  7936.             cld
  7937.             lodsb                      { Length of current directory string }
  7938.             mov   cl,al
  7939.             rep   movsb
  7940.             mov   al,'\'               { Add the trailing backslash         }
  7941.             stosb
  7942.  
  7943.             pop   ds                   { DS:SI = @Source[n]                 }
  7944.             pop   cx
  7945.             pop   si
  7946.  
  7947. @@3:        sub   cx,si                { Copy rest of source path to result }
  7948.             rep   movsb
  7949.  
  7950.             mov   ax,cx                { AX = 0                             }
  7951.             push  es
  7952.             lea   si,[Result]
  7953.             stosb                      { End of result string marker        }
  7954.             lea   si,[Result]
  7955.             pop   ds                   { DS:SI = @Result                    }
  7956.             pop   cx                   { CX = MaxLen argument               }
  7957.             pop   di                   { ES:DI = @Target                    }
  7958.             pop   es
  7959.             mov   dx,di                { Save Target.Ofs in DX              }
  7960.  
  7961. @@4:        lodsb                      { Run through the result string to   }
  7962.             or    al,al                { look for and remove any expanded   }
  7963.             jz    @@6                  { parts copied from the source path  }
  7964.             cmp   al,'\'               { All expanded parts are terminated  }
  7965.             je    @@6                  { by a backslash character           }
  7966. @@5:        stosb
  7967.             loop  @@4
  7968.             mov   ax,201               { Range check error                  }
  7969.             jmp   @@Exit
  7970.  
  7971. @@6:        cmp   word ptr [di-2],'.\' { "Root Directory" expanded?         }
  7972.             jne   @@7                  { No                                 }
  7973.             sub   di,2                 { Remove the ".\" from result        }
  7974.             jmp   @@9
  7975.  
  7976. @@7:        cmp   word ptr [di-2],'..' { "Parent Directory" expanded?       }
  7977.             jne   @@9                  { No                                 }
  7978.             cmp   byte ptr [di-3],'\'  { ".." will have a double \\ before  }
  7979.             jne   @@9                  { it after expansion, so remove it   }
  7980.             sub   di,3
  7981.             cmp   byte ptr [di-1],':'
  7982.             je    @@9
  7983. @@8:        dec   di
  7984.             cmp   byte ptr [di],'\'
  7985.             jne   @@8
  7986. @@9:        or    al,al
  7987.             jne   @@5
  7988.             cmp   byte ptr [di-1],':'  { If the expanded path is just "D:"  }
  7989.             jne   @@10                 { then add a backslash to make it    }
  7990.             mov   al,'\'               { relative to the root directory.    }
  7991.             stosb
  7992.             xor   ax,ax
  7993.  
  7994. @@10:       push  es                   { ES:DI = @Target.NullChar           }
  7995.             push  di                   { Store null terminator              }
  7996.             stosb                      { Convert case of path according to  }
  7997.             push  es                   { (ES:DX = @Target)                  }
  7998.             push  dx                   { drive properties & user preferences}
  7999.             mov   dx,seg @Data
  8000.             mov   ds,dx
  8001.             call  ConvertPathCase
  8002.             xor   ax,ax                { Returns AX = ZF = 0 if no error    }
  8003.             pop   di                   { ES:DI = @Target.LastChar + 1       }
  8004.             pop   es
  8005.  
  8006. @@Exit:     pop   ds
  8007.             or    ax,ax
  8008. end;
  8009.  
  8010. function FStdExpand(Path: TPathStr): TPathStr; assembler;        { NOT USED }
  8011. asm
  8012.             push  ds
  8013.             lds   si,[Path]            { DS:SI = @Source path               }
  8014.             cld
  8015.             lodsb                      { AL = Len(Path)                     }
  8016.             xor   cx,cx
  8017.             les   di,[@Result]         { ES:DI = @Result                    }
  8018.             mov   cl,al                { CX = Length(Path)                  }
  8019.             inc   di                   { Move past Result length byte       }
  8020.             mov   ax,type TPathStr-1   { AX = max length of return string   }
  8021.             jcxz  @@2
  8022.             call  ExpandPath           { ES:DI @Result[1] DS:SI @Path[1]    }
  8023.             jz    @@1                  { No Error                           }
  8024.             lds   si,[Path]            { Return Path unchanged              }
  8025.             push  ax
  8026.             xor   ax,ax
  8027.             les   di,[@Result]
  8028.             lodsb
  8029.             stosb
  8030.             rep   movsb
  8031.             pop   ax
  8032.             jmp   @@Exit
  8033.  
  8034. @@1:        mov   ax,di                { ES:AX = @LastChar+1                }
  8035.             les   di,[@Result]         { ES:DI = @Length byte               }
  8036.             sub   ax,di
  8037.             dec   ax
  8038. @@2:        stosb                      { Store string length byte,+         }
  8039.             xor   ax,ax
  8040.  
  8041. @@Exit:     pop   ds
  8042.             mov   [InOutRes],ax
  8043. end;
  8044.  
  8045. function FileStdExpand(Dest, Name: PChar): PChar; assembler;     { NOT USED }
  8046. asm
  8047.             push  ds
  8048.     db $66; push  [Name].Word[0]       { Get length of source string        }
  8049.             call  StrLen
  8050.             lds   si,[Name]            { DS:SI = @source path               }
  8051.             mov   cx,ax                { CX = Length(Name)                  }
  8052.             les   di,[Dest]            { ES:DI = @Result                    }
  8053.             cld
  8054.             mov   ax,fsPathName        { AX = Max length of return string   }
  8055.             jcxz  @@1                  { Null Name returns a null Dest      }
  8056.             call  ExpandPath           { ES:DI = @Result DS:SI @Arg CX=Len  }
  8057. @@1:        pop   ds
  8058.             mov   [InOutRes],ax
  8059. end;
  8060.  
  8061. { Looks for the network drive specified in P. Returns nil if P doesn't }
  8062. { denote a locally mapped network drive. (NOT USED)                    }
  8063.  
  8064. function GetNetVolume(Path: PChar): PVolumeInfo;
  8065. var
  8066.   V: PVolumeInfo;
  8067.   P: TNetPath;
  8068.   N: TNetName;
  8069. begin
  8070.   P := StrLPas(Path, High(TNetPath));
  8071.   {$V-} DosUpperCase(P); {$V+}
  8072.   V := Get1stNetDrive;
  8073.   while V <> nil do
  8074.    begin
  8075.      if (V^.Attributes and vaIsNetworkDrive) <> 0 then
  8076.       begin
  8077.         N := V^.NetName^;
  8078.         {$V-} DosUpperCase(N); {$V+}
  8079.         if Compare(N[1], P[1], Length(N)) = 0
  8080.          then Break;
  8081.       end;
  8082.      V := V^.Next;
  8083.    end;
  8084.   GetNetVolume := V;
  8085. end;
  8086.  
  8087. { Returns the ordinal position of the first wild character in P, or 0 }
  8088. { if P does not contain any wildcards. Return value is 1 based.       }
  8089.  
  8090. function FirstWildChar(P: PChar): Word; assembler;
  8091. asm
  8092.             push  P.Word[2]
  8093.             push  P.Word[0]
  8094.             call  StrLen
  8095.             les   di,[P]
  8096.             mov   bx,ax
  8097.             mov   cx,ax
  8098.             mov   al,'*'
  8099.             repne scasb
  8100.             je    @@1
  8101.             mov   cx,bx
  8102.             sub   di,bx
  8103.             mov   al,'?'
  8104.             repne scasb
  8105.             mov   ax,0
  8106.             jne   @@Exit
  8107. @@1:        mov   ax,bx
  8108.             sub   ax,cx
  8109. @@Exit:
  8110. end;
  8111.  
  8112. { Return the start position of the next component in Path to the left of   }
  8113. { LastPos. Returns 0 if start of Path. Path must be a local drive path     }
  8114.  
  8115. function PrevPathComp(Path: PChar; LastPos: Word): Word; assembler;
  8116. asm
  8117.             push  ds
  8118.             lds   si,[Path]
  8119.             mov   cx,[LastPos]
  8120.             std
  8121.             jcxz  @@Exit
  8122.             dec   cx
  8123.             add   si,cx
  8124.             jcxz  @@Exit
  8125.  
  8126. @@NxtChar:  lodsb
  8127.             cmp   al,':'
  8128.             je    @@Found
  8129.             cmp   al,'\'
  8130.             je    @@Found
  8131.             loop  @@NxtChar
  8132.  
  8133. @@Found:    inc   cx
  8134.             cmp   cx,[LastPos]
  8135.             jb    @@Exit
  8136.             dec   cx
  8137.             loop  @@NxtChar
  8138.  
  8139. @@Exit:     mov   ax,cx
  8140.             cld
  8141.             pop   ds
  8142. end;
  8143.  
  8144. { Checks the lengths of each path component of P against the MaxNameLen and }
  8145. { MaxExtLEn of the TVolumeInfo in V. Also checks entire path length against }
  8146. { MaxPathLen. P must not be a network path. DosError set if P invalid.      }
  8147.  
  8148. function ValidPath(P: PChar; V: PVolumeInfo): Boolean; near; assembler;
  8149. var
  8150.   EndPos, LastPos: Word;
  8151.   MaxName,MaxExt : Word;
  8152.   CompCnt        : Word;
  8153. asm
  8154.             les   di,[V]
  8155.             mov   [CompCnt],0
  8156.             mov   ax,es:[di].TVolumeInfo.MaxNameLen
  8157.             mov   [MaxName],ax
  8158.             mov   ax,es:[di].TVolumeInfo.MaxExtLen
  8159.             mov   [MaxExt],ax
  8160.             push  es:[di].TVolumeInfo.MaxPathLen
  8161.    db $66;  push  [P].Word[0]
  8162.             call  StrLen                { EndPos := StrLen(P)               }
  8163.             pop   cx                    { CX = V^.MaxPathLen                }
  8164.             mov   [EndPos],ax
  8165.             cmp   ax,cx
  8166.             jbe   @@NxtComp
  8167.             mov   [DosError],dePathTooLong
  8168.             jmp   @@Error
  8169.  
  8170. @@NxtComp:  db $66; push [P].Word[0]    { LastPos:= PrevPathComp(P, EndPos) }
  8171.             push  [EndPos]
  8172.             call  PrevPathComp
  8173.             les   di,[P]
  8174.             mov   cx,[EndPos]
  8175.             add   di,ax                 { S := P + LastPos                  }
  8176.             sub   cx,ax                 { Count := EndPos - LastPos         }
  8177.             mov   [LastPos],ax
  8178.             dec   ax
  8179.             cld
  8180.             mov   [EndPos],ax           { EndPos := LastPos -1              }
  8181.             jcxz  @@Ok
  8182.             cmp   cx,[MaxName]
  8183.             mov   al,'.'
  8184.             jbe   @@ChkExt
  8185.             mov   [DosError],deNameTooLong
  8186.             cmp   [CompCnt],0
  8187.             je    @@Error
  8188.             mov   [DosError],deDirTooLong
  8189.             jmp   @@Error
  8190.  
  8191. @@ChkExt:   repne scasb
  8192.             jne   @@Ok
  8193.             inc   cx
  8194.             cmp   cx,[MaxExt]
  8195.             jbe   @@Ok
  8196.             mov   [DosError],deExtTooLong
  8197. @@Error:    mov   al,false
  8198.             jmp   @@Exit
  8199.  
  8200. @@Ok:       inc   [CompCnt]
  8201.             cmp   [LastPos],0
  8202.             jne   @@NxtComp
  8203.             mov   al,true
  8204. @@Exit:
  8205. end;
  8206.  
  8207. { Returns the cannonical path and filename of the Path argument. The local  }
  8208. { substituted drive is returned for networked drives unless fcNetPath is set}
  8209. { Wildcards are only allowed if the fcWildcards flags is set.               }
  8210.  
  8211. function FExpand(const Path: String; Flags: Word): TPathStr;
  8212. var
  8213.   Name  : array[0..High(String)] of Char;
  8214.   MaxLen: Word;
  8215. begin
  8216.   MaxLen := High(TPathStr);
  8217. {$ifndef LongNames}                    { MaxLen not needed with LFN because }
  8218.   if Flags and fcNetPath <> 0          { TPathStr and TNetPath are same size}
  8219.    then MaxLen := High(TNetPath);
  8220. {$endif !LongNames}
  8221.   FileExpand(@Name, StrPCopy(@Name, Path), Flags);
  8222.   FExpand := StrLPas(@Name, MaxLen);
  8223.   if DosError = deNoError
  8224.    then DosError := StrError;
  8225. end;
  8226.  
  8227. type
  8228.   PFileExpand = ^TFileExpand;
  8229.   TFileExpand = record
  8230.     SR      : TDosSearch;
  8231.     LongPath: TPathNet;
  8232.     NetPath : TPathNet;
  8233.   end;
  8234.  
  8235. function FileExpand(Dest, Name: PChar; Flags: Word): PVolumeInfo;
  8236. var
  8237.   Regs    : TRegisters;
  8238.   P       : PFileExpand absolute DosBuf;
  8239.   SaveBuf : TFileExpand;
  8240.   V       : PVolumeInfo;
  8241.   Pos     : Integer;
  8242.   NewPos  : Integer;
  8243.   SaveChar: Char;
  8244.   Padder  : Char;
  8245.   MaxLen  : Word;
  8246.   SR      : TSearchRec;
  8247. label
  8248.   Error, Done, GetOut;
  8249. begin
  8250.   CheckDosBuf(SaveBuf, SizeOf(SaveBuf));
  8251.   ClearRegs(Regs);
  8252.   StrLCopy(@P^.NetPath, Name, fsNetPath);
  8253.  
  8254.   MaxLen := fsPathName;
  8255.   if Flags and fcNetPath <> 0
  8256.    then MaxLen := fsNetPath;
  8257.  
  8258.   { Determine the volume of Name from its path. Network }
  8259.   { names are converted to their local drive equivalent }
  8260.  
  8261.   V := GetVolumeFromPath(@P^.NetPath); { Appends 'X:' if no drive specified }
  8262.   FileExpand := V;
  8263.   if V = nil
  8264.    then goto Error;
  8265.  
  8266.   { Make sure the local drive path is not too long }
  8267.   { and does not contain any overlength components }
  8268.  
  8269.   if not ValidPath(@P^.NetPath, V) then
  8270. Error:
  8271.    begin
  8272.      StrLCopy(Dest, Name, MaxLen);
  8273.      goto GetOut;
  8274.    end;
  8275.  
  8276.   { At this point we have validated the drive and made sure Name }
  8277.   { is not to long and doesn't contain any overlength components.}
  8278.  
  8279.   if Flags and fcFileName <> 0
  8280.    then Flags := Flags or fcDirectory;
  8281.  
  8282.   { The DOS/LFN functions don't handle wildcard characters as we would like,}
  8283.   { so only use the DOS/LFN function to expand the drive and directory if   }
  8284.   { Name contains wildcards (in the Name.Ext), then add the Name.Ext        }
  8285.   { containing the wildcard[s] to the expanded directory afterwards.        }
  8286.  
  8287.   Pos := FirstWildChar(@P^.NetPath);
  8288.   if Pos <> 0 then
  8289.    begin
  8290.      if Flags and fcWildCards = 0 then
  8291.       begin
  8292.         DosError := deNoWildCards;
  8293.         goto Error;
  8294.       end;
  8295.      if Flags and fcDirectory <> 0        { If we are to verify the dir     }
  8296.       then Flags := Flags or fcFileName;  { then rest of the path must exist}
  8297.      repeat
  8298.        Dec(Pos);
  8299.      until (Pos = 0) or (P^.NetPath[Pos] = '\') or (P^.NetPath[Pos] = ':');
  8300.  
  8301.      { The Name.Ext contains wildcard[s], but a path of some sort has also  }
  8302.      { the been supplied or added, so we'll expand the given directory path }
  8303.      { then add Name.Ext to the expanded directory path at the end.         }
  8304.  
  8305.      Inc(Pos);
  8306.      SaveChar := P^.NetPath[Pos];           { Replace 1st name char with #0 }
  8307.      P^.NetPath[Pos] := #0;
  8308.    end;
  8309.  
  8310.   { Use the operating system call to expand the given path. The LFN  }
  8311.   { version should translate network names to local drive names.     }
  8312.  
  8313.   ClearRegs(Regs);
  8314.   Regs.ES := DosBuf.RealSeg;
  8315.   Regs.DI := SizeOf(TDosSearch);       { ES:DI = @P^.LongPath               }
  8316.   Regs.DS := Regs.ES;
  8317.   Regs.SI := SizeOf(TDosSearch) + SizeOf(TPathNet); { DS:SI = @P^.NetPath   }
  8318.   Regs.AH := $60;                      { DOS - Get cannonical true name     }
  8319. {$ifdef LongNames}
  8320.   if V^.Attributes and vaDosLongNames <> 0 then
  8321.    begin
  8322.      Regs.AX := $7160;                 { LFN - Get cannonical path          }
  8323.      Regs.CX := $8000;                 { Return subst'd drive               }
  8324.    end;
  8325. {$endif LongNames}
  8326.   DosError:= MsDos(Regs);
  8327.   if Regs.Flags and fCarry = 0
  8328.    then begin
  8329.           DosError := 0;
  8330.           if Flags and (fcFileName + fcDirectory) <> 0 then
  8331.            repeat      { Either the full path or the directory has to exist }
  8332. {$ifdef LongNames}
  8333.              if V^.Attributes and vaDosLongNames <> 0
  8334.               then begin
  8335.                      { Expand any short 8.3 DOS alias file/dir names to  }
  8336.                      { their true longname. May return 'PathNotFound'    }
  8337.                      { WIN95 BUG: Does not always return qualified path! }
  8338.                      { Passing "[C:]FILENAME.EXT" returns unchanged!!!!  }
  8339.  
  8340.                      Regs.AX := $7160;      { LFN - Get cannonical LFN path }
  8341.                      Regs.CX := $8002;      { Return subst'd drive          }
  8342.                      DosError:= MsDos(Regs);
  8343.                      if Regs.Flags and fCarry = 0
  8344.                       then DosError := deNoError;
  8345.                    end
  8346.               else
  8347. {$endif LongNames} begin
  8348.                      { We'll use the DOS FindFirst function to determine if }
  8349.                      { the path exists. TDosSearch is returned in the DTA   }
  8350.  
  8351.                      Regs.DX := SizeOf(TDosSearch); { DS:DX = @ASCIIZ filter}
  8352.                      Regs.CX := faAnything;
  8353.                      Regs.AH := $4E;   { AH = Dos Function (FindFirstFile)  }
  8354.                      DosError:= MsDos(Regs);            { DOS - FindFirst   }
  8355.                      if Regs.Flags and fCarry = 0
  8356.                       then DosError := deNoError
  8357.                       else if DosError = deNoMoreFiles
  8358.                              then DosError := dePathNotFound;
  8359.                    end;
  8360.              if DosError <> deNoError then
  8361.               begin
  8362.                 if Flags and fcFileName <> 0     { Whole path must exist or }
  8363.                  then Break;                     { removed NAME.EXT already }
  8364.                 Inc(Flags, fcFileName);          { Break on next iteration  }
  8365.  
  8366.                 { Remove FILENAME.EXT from P^.LongPath and try again }
  8367.  
  8368.                 NewPos := PrevPathComp(@P^.LongPath, StrLen(P^.LongPath));
  8369.                 if NewPos > 3                  { Only keep the trailing '\' }
  8370.                  then Pos := NewPos-1          { if we are at the root dir  }
  8371.                  else begin                    { Otherwise we know the path }
  8372.                         DosError := deNoError; { is valid because the       }
  8373.                         Break;                 { GetVolumeFromPath function }
  8374.                       end;                     { has told us already.       }
  8375.                 P^.LongPath[Pos] := #0;
  8376.  
  8377.                 { Mark the position of FILENAME.EXT in P^.NetPath }
  8378.  
  8379.                 Pos := PrevPathComp(@P^.NetPath, StrLen(P^.NetPath));
  8380.                 if Pos > 3                   { Only keep the trailing '\'   }
  8381.                  then Dec(Pos);              { if we are at the root dir    }
  8382.                 if Pos > 0 then
  8383.                  begin
  8384.                    SaveChar := P^.NetPath[Pos];
  8385.                    P^.NetPath[Pos] := #0;
  8386.                  end;
  8387.               end;
  8388.           until (DosError = deNoError) or (Pos <= 0);
  8389.           if (Flags and fcNetPath = 0) and (P^.LongPath[1] <> ':')
  8390.            then ConvertNetPath(@P^.LongPath);       { Not normal 'X:\' form }
  8391.           StrLCopy(Dest, P^.LongPath, MaxLen);      { Net name -> drv name  }
  8392.           if Flags and fcCasePreserve = 0
  8393.            then ConvertPathCase(Dest, V);    { Convert file case of result  }
  8394.         end
  8395.    else begin
  8396.           StrLCopy(Dest, Name, MaxLen);      { Given path is invalid        }
  8397.           if Integer(Word(DosError) - 2) < 1 { Invalid/Malformed component  }
  8398.            then DosError := deInvalidPath;
  8399.         end;
  8400. Done:
  8401.   if Pos <> 0 then                     { Add non-exsistant part of path to  }
  8402.    begin                               { the returned expanded path string  }
  8403.      if SaveChar <> '\'
  8404.       then AddDirSepStr(Dest);         { Add trailing backslash to directory}
  8405.      P^.NetPath[Pos] := SaveChar;      { Add Name.Ext to directory.         }
  8406.      StrLCat(Dest, PChar(@P^.NetPath[Pos]), MaxLen);
  8407.      if DosError = deNoError
  8408.       then DosError := StrError;
  8409.    end;
  8410. GetOut:
  8411.   RestoreDosBuf(SaveBuf, SizeOf(SaveBuf));
  8412. end;
  8413.  
  8414. function FDosExpand(const Path: TPathStr): TDosPath;
  8415. var
  8416.   P: TPathName;
  8417. begin
  8418.   PasToNull(Path, @P);
  8419.   FileDosExpand(@P, @P);
  8420.   FDosExpand := StrLPas(@P, High(TPathStr));
  8421. end;
  8422.  
  8423. function FileDosExpand(DosPath, LongPath: PChar): PChar;
  8424. {$ifdef LongNames}
  8425. var
  8426.   Regs   : TRegisters;
  8427.   P      : PNetNet absolute DosBuf;
  8428.   SaveBuf: TNetNet;
  8429.   V      : PVolumeInfo;
  8430. begin
  8431.   FileDosExpand := DosPath;
  8432.  
  8433.   { We have to determine what volume is associated with Path in order to    }
  8434.   { determine whether to use the DOS or the LFN "truename" function.        }
  8435.  
  8436.   V := GetVolumeFromPath(LongPath);
  8437.   if (V <> nil) and (V^.Attributes and vaDosLongNames <> 0)
  8438.    then begin
  8439.           CheckDosBuf(SaveBuf, SizeOf(SaveBuf));
  8440.           StrLCopy(@P^.LongPath, LongPath, High(TNetPath));
  8441.           ClearRegs(Regs);
  8442.           Regs.DS := DosBuf.RealSeg;      { Convert long path and put in    }
  8443.           Regs.ES := Regs.DS;             { DosBuf. DS:SI = @P^.LongPath    }
  8444.           Regs.DI := SizeOf(TPathNet);    { ES:DI = @P^.NetPath             }
  8445.           Regs.CX := $8001;               { Get short path, use subst drive }
  8446.           Regs.AX := $7160;               { LFN - Get short filename        }
  8447.           DosError:= MsDos(Regs);
  8448.           if Regs.Flags and fCarry = 0
  8449.            then begin
  8450.                   if P^.NetPath[1] <> ':'            { Not normal 'X:\' form}
  8451.                    then ConvertNetPath(@P^.NetPath); { Net name -> drv name }
  8452.                   StrLCopy(DosPath, P^.NetPath, fsDosPath);
  8453.                 end
  8454.            else StrLCopy(DosPath, LongPath, fsDosPath);
  8455.           RestoreDosBuf(SaveBuf, SizeOf(SaveBuf));
  8456.         end
  8457.    else
  8458. {$else LongNames}
  8459. begin
  8460. {$endif LongNames}
  8461.         FileExpand(DosPath, LongPath, fcCasePreserve);
  8462.   FileDosExpand := DosPath;
  8463. end;
  8464.  
  8465. function FDosContract(const Name: TPathStr): TDosPath;
  8466. var
  8467.   CD,ND: TPathStr;                               { Current Dir  / Name Dir  }
  8468.   DL,NL: Byte;                                   { Length(CD) / Length(Name)}
  8469. begin
  8470.   {$V-}
  8471.   ND := FDosExpand(Name);                        { 8.3 name of Name path    }
  8472.   DelDirSep(ND);
  8473.   GetDir(0, CD);
  8474.   CD := FDosExpand(CD);                          { 8.3 name of current path }
  8475.   DelDirSep(CD);
  8476.   {$V+}
  8477.   DL := Length(CD);
  8478.   NL := Length(ND);
  8479.   if (NL > DL) and (ND[DL+1] = '\') and (Compare(CD[1], ND[1], DL) = 0)
  8480.    then FDosContract := Copy(ND, DL+2, 255)
  8481.    else FDosContract := ND;
  8482. end;
  8483.  
  8484. function FileDosContract(Dest, Name: PChar): PChar;
  8485. var
  8486.   CD,ND: TPathName;
  8487.   DL,NL: Word;
  8488. begin
  8489.   DelDirSepStr(FileDosExpand(@ND, Name));
  8490.   DelDirSepStr(FileDosExpand(@CD, GetCurDir(@CD, 0)));
  8491.   DL := StrLen(@CD);
  8492.   NL := StrLen(@NL);
  8493.   if (NL > DL) and (ND[DL+1] = '\') and (Compare(CD, ND, DL) = 0)
  8494.    then StrLCopy(Dest, @ND[DL+1], fsPathName)
  8495.    else StrLCopy(Dest, Name, fsPathName);
  8496.   FileDosContract := Dest;
  8497. end;
  8498.  
  8499. function FContract(const Path: TPathStr): TPathStr;
  8500. var
  8501.   CD   : TDirStr;                                { Current Directory        }
  8502.   DL,NL: Byte;                                   { Length(CD) / Length(Name)}
  8503. begin
  8504.   {$V-}
  8505.   GetDir(0, CD);
  8506.   DelDirSep(CD);
  8507.   {$V+}
  8508.   DL := Length(CD);
  8509.   NL := Length(Path);
  8510.   if (NL > DL) and (Path[DL+1] = '\') and
  8511.      (Compare(CD[1], Path[1], DL) = 0)
  8512.    then FContract := Copy(Path, DL+2, 255)
  8513.    else FContract := Path;
  8514. end;
  8515.  
  8516. function FileContract(Dest, Name: PChar): PChar;
  8517. var
  8518.   CD,ND: TPathName;
  8519.   DL,NL: Word;
  8520. begin
  8521.   DelDirSepStr(GetCurDir(@CD, 0));
  8522.   DL := StrLen(CD);
  8523.   StrLCopy(@ND, Name, fsPathName);
  8524.   NL := StrLen(ND);
  8525.   if (NL > DL) and (ND[DL+1] = '\') and (Compare(CD, ND, DL) = 0)
  8526.    then StrLCopy(Dest, @ND[DL+1], fsPathName)
  8527.    else StrLCopy(Dest, Name, fsPathName);
  8528.   FileContract := Dest;
  8529. end;
  8530.  
  8531. function FSearch(const Path: String; DirList: String): TPathStr;
  8532.  
  8533.   function GetNextDir: TDirStr; near;
  8534.   var
  8535.     P: Integer;
  8536.   begin
  8537.     P := Pos(';', DirList);
  8538.     if P = 0
  8539.      then P := Length(DirList) + 1;
  8540.     GetNextDir := Copy(DirList, 1, P-1);
  8541.     DirList := Copy(DirList, P+1, 255);
  8542.   end;
  8543.  
  8544. var
  8545.   Dir: TPathStr;
  8546.   SR : TSearchRec;
  8547. begin
  8548.   FSearch := '';
  8549.   if Length(Path) = 0
  8550.    then Exit;
  8551.   if (Path[1] = '\') or (Path[1] = '/') or (Path[2] = ':')   { If given the }
  8552.    then DirList := '';                    { path or current directory, then }
  8553.   repeat                                  { don't use the DirList at all.   }
  8554.     Dir := GetNextDir;
  8555.     if (Dir <> '') and (Dir[Length(Dir)] <> '\')
  8556.      then Dir := Dir + '\';
  8557. {$ifdef Windows}
  8558.     PasToNull(Dir + Path, @Dir);
  8559.     FindFirst(@Dir, faArchive + faReadOnly + faSysFile, SR);
  8560. {$else Windows}
  8561.     FindFirst(Dir + Path, faAnyFile, SR);
  8562. {$endif Windows}
  8563.     if IOResult = deNoError then
  8564.      begin
  8565.        FindClose(SR);
  8566.        FSearch := FExpand(Dir + Path, fcFileName);
  8567.        Exit;
  8568.      end;
  8569.   until DirList = '';
  8570. end;
  8571.  
  8572. function FileSearch(Dest, Path, DirList: PChar): PChar;
  8573. begin
  8574.   FileSearch := StrPCopy(Dest, FSearch(NullToPas(Path), NullToPas(DirList)));
  8575. end;
  8576.  
  8577. procedure FSplit(const Path: TPathStr; var Dir: TDirStr; var Name: TNameStr;
  8578.                  var Ext: TExtStr);
  8579. var
  8580.   N: TPathName;              { Splits a path into its constituent parts.    }
  8581.   P: PChar;                  { Ext contains the last "." plus all characters}
  8582.   C: Word;                   { after the last ".", up to the maximum allowed}
  8583. begin                        { for TExtStr. Name contains all characters    }
  8584.   P := @N;                   { after the last "\", excluding the extension  }
  8585.   C := PasToNull(Path, P);   { (if any). Dir will contain all remaining     }
  8586.   Inc(P, C);                 { characters (if any) in Path, including any   }
  8587.   Dir := '';                 { trailing '\' character.                      }
  8588.   Name:= '';                 { Any or all returned components could be null.}
  8589.   Ext := '';
  8590.   while C <> 0 do
  8591.    begin
  8592.      Dec(P);
  8593.      Dec(C);
  8594.      case P^ of
  8595.       '.':
  8596.         if Ext = '' then
  8597.          begin
  8598.            Ext := StrLPas(P, High(TExtStr));
  8599.            P^ := #0;
  8600.          end;
  8601.       '\':
  8602.         if Name = '' then
  8603.          begin
  8604.            Inc(P);
  8605.            Inc(C);
  8606.            Name := StrLPas(P, High(TNameStr));
  8607.            P^ := #0;
  8608.            Dir := StrLPas(@N, High(TDirStr));
  8609.            Exit;
  8610.          end;
  8611.      end;
  8612.    end;
  8613.   Name := StrLPas(@N, High(TDirStr))
  8614. end;
  8615.  
  8616. function FileSplit(Path, Dir, Name, Ext: PChar): Word;
  8617. var
  8618.   N: TPathName;              { Splits a path into its constituent parts.    }
  8619.   P: PChar;                  { Ext contains the last "." plus all characters}
  8620.   C: Word;                   { after the last ".", up to the maximum allowed}
  8621.   R: Word;                   { for TExtStr. Name contains all characters    }
  8622. begin                        { after the last "\", excluding the extension  }
  8623.   R   := 0;                  { (if any). Dir will contain all remaining     }
  8624.   P   := @N;                 { characters (if any) in Path, including any   }
  8625.   C   := StrLCopy(P, Path, fsPathName);       { trailing '\' character.     }
  8626.   SlashConvert(C, N);        { Any or all returned components could be null.}
  8627.   Inc(P, C);                 { the returned word indicates those parts that }
  8628.   Dir^ := asNull;            { that contain a non-null string.              }
  8629.   Name^:= asNull;
  8630.   Ext^ := asNull;
  8631.   while C <> 0 do
  8632.    begin
  8633.      Dec(P);
  8634.      Dec(C);
  8635.      case P^ of
  8636.       '.':
  8637.         if R and (fcExtension + fcFileName) = 0 then
  8638.          begin
  8639.            StrLCopy(Ext, P, fsExtension);
  8640.            P^ := #0;
  8641.            R  := fcExtension;
  8642.          end;
  8643.       '*','?':
  8644.         R := R or fcWildCards;
  8645.       '\':
  8646.         if R and fcFileName = 0 then
  8647.          begin
  8648.            Inc(P);
  8649.            Inc(C);
  8650.            if StrLCopy(Name, P, fsFileName) <> 0
  8651.             then Inc(R, fcFileName);
  8652.            P^ := #0;
  8653.            if StrLCopy(Dir, @N, fsDirectory) <> 0
  8654.             then Inc(R, fcDirectory);
  8655.            FileSplit := R;
  8656.            Exit;
  8657.          end;
  8658.      end;
  8659.    end;
  8660.   if StrLCopy(Name, @N, fsDirectory) <> 0
  8661.    then Inc(R, fcFileName);
  8662.   FileSplit := R;
  8663. end;
  8664.  
  8665. function FCompare(Name1, Name2: String): Integer;
  8666. var
  8667.   Result: Integer;
  8668.   L1,L2 : Integer;
  8669.   V     : PVolumeInfo;
  8670. begin
  8671.   PasToNull(Name1, @Name1);
  8672.   PasToNull(Name2, @Name2);
  8673.   FCompare := FileCompare(@Name1, @Name2);
  8674. end;
  8675.  
  8676. function FileCompare(Name1, Name2: PChar): Integer;
  8677. var
  8678.   Result: Integer;
  8679.   L1,L2 : Integer;
  8680.   N1,N2 : TPathName;
  8681.   V     : PVolumeInfo;
  8682. begin
  8683.   FileExpand(@N2, Name2, fcWildcards + fcDirectory + fcCasePreserve);
  8684.   DelDirSepStr(@N2);
  8685.   L2 := StrLen(@N2);
  8686.   V := FileExpand(@N1, Name1, fcWildcards + fcDirectory + fcCasePreserve);
  8687.   DelDirSepStr(@N1);
  8688.   L1 := StrLen(@N1);
  8689.   if (DosError = deNoError) and (V^.Attributes and vaCaseSensitive = 0) then
  8690.    begin
  8691.      StrUpper(@N1);
  8692.      StrUpper(@N2);
  8693.    end;
  8694.   Result := Compare(N1, N2, Min(L1, L2));
  8695.   if (Result = 0) and (L1 <> L2)
  8696.    then Result := -1 + (Ord(L1 > L2) shl 1);
  8697.   FileCompare := Result;
  8698. end;
  8699.  
  8700. procedure FErase(const FileName: String);
  8701. var
  8702.   Name: array[0..High(String)] of Char;
  8703. begin
  8704.   PasToNull(FileName, @Name);
  8705.   FileErase(@Name);
  8706. end;
  8707.  
  8708. procedure FileErase(FileName: PChar);
  8709. {$ifdef TurboLong} assembler;
  8710. asm
  8711.             push  ds
  8712.   {$ifdef LongNames}
  8713.             mov   [DosError],0
  8714.     db $66; mov   ax,[FileName].Word[0]
  8715.             call  CheckForLfnDrv
  8716.             mov   ah,$41               { DOS - delete file                  }
  8717.             jz    @@NoLFN
  8718.             mov   ax,$7141             { LFN - delete file                  }
  8719.             xor   si,si                { No wildcards allowed               }
  8720. @@NoLFN:    xor   cx,cx
  8721.   {$else LongNames}
  8722.             xor   cx,cx
  8723.             mov   [DosError],cx
  8724.             mov   ah,$41               { DOS - delete file                  }
  8725.   {$endif LongNames}
  8726.             lds   dx,[FileName]        { DS:DX = @FileName                  }
  8727.             int   intDos
  8728.             pop   ds
  8729.             jnc   @@Exit
  8730.             call  GetExtError
  8731. @@Exit:
  8732. end;
  8733. {$else TurboLong}
  8734. var
  8735.   Regs   : TRegisters;
  8736.   Name   : PChar absolute DosBuf;
  8737.   SaveBuf: TPathNet;
  8738.   V      : PVolumeInfo;
  8739. label
  8740.   Error;
  8741. begin
  8742.   ClearRegs(Regs);
  8743.   CheckDosBuf(SaveBuf, SizeOf(SaveBuf));
  8744.   StrLCopy(Name, FileName, fsNetPath);
  8745.   Regs.DS := DosBuf.RealSeg;
  8746.   Regs.AH := $41;                           { DOS - delete file             }
  8747.   Regs.Flags := fCarry;
  8748.   {$ifdef LongNames}
  8749.   V := GetVolumeFromPath(Name);
  8750.   if V = nil
  8751.     then goto Error;
  8752.   if V^.Attributes and vaDosLongNames <> 0
  8753.    then Regs.AX := $7141;                   { LFN - delete file             }
  8754.   {$endif LongNames}
  8755.   DosError := MsDos(Regs);
  8756.   if Regs.Flags and fCarry = 0
  8757.    then DosError := 0
  8758.    else GetExtError;
  8759. Error:
  8760.   RestoreDosBuf(SaveBuf, SizeOf(SaveBuf));
  8761. end;
  8762. {$endif TurboLong}
  8763.  
  8764. procedure FRename(const OldName, NewName: String);
  8765. var
  8766.   Old: array[0..High(String)] of Char;
  8767.   New: array[0..High(String)] of Char;
  8768. begin
  8769.   PasToNull(OldName, Old);
  8770.   PasToNull(NewName, New);
  8771.   FileRename(@Old, @New);
  8772. end;
  8773.  
  8774. procedure FileRename(OldName, NewName: PChar);
  8775. {$ifdef TurboLong} assembler;
  8776. var
  8777.   New: TPathName;
  8778. asm
  8779.             lea   si,[New]
  8780.             push  ss                           { FileExpand.Dest argument   }
  8781.             push  si
  8782.     db $66; push  word ptr [NewName]           { FileExpand.Path argument   }
  8783.             push  fcDirectory + fcCasePreserve { New doesn't have to exist  }
  8784.             push  cs                           { but it needs validating    }
  8785.             call  near ptr FileExpand          { because DOS Rename will    }
  8786.             cmp   [DosError],deNoError         { trancate an overlength     }
  8787.             jne   @@Exit                       { name and give no error!    }
  8788.  
  8789.             mov   es,dx                        { ES:DI = @VolumeInfo        }
  8790.             mov   di,ax
  8791.             push  ds
  8792.             mov   ah,$56                       { DOS - Rename File          }
  8793.             xor   cx,cx
  8794.             mov   [DosError],cx
  8795.   {$ifdef LongNames}
  8796.             test  es:[di].TVolumeInfo.Attributes,vaDosLongNames
  8797.             je    @@1
  8798.             mov   ax,$7156                     { LFN - Rename File          }
  8799.   {$endif LongNames}
  8800. @@1:        lds   dx,[OldName]                 { DS:DX = @Old_name          }
  8801.             push  ss
  8802.             lea   di,[New]
  8803.             pop   es                           { ES:DI = @New_name          }
  8804.             int   intDos
  8805.             pop   ds
  8806.             jnc   @@Exit
  8807.             call   GetExtError
  8808. @@Exit:
  8809. end;
  8810. {$else TurboLong}
  8811. var
  8812.   Regs   : TRegisters;
  8813.   Names  : PRename absolute DosBuf;
  8814.   SaveBuf: TRename;
  8815.   New    : TPathName;
  8816.   Flags  : Word;
  8817.   V      : PVolumeInfo;
  8818. label
  8819.   Done;
  8820. begin
  8821.   ClearRegs(Regs);
  8822.   CheckDosBuf(SaveBuf, SizeOf(SaveBuf));         { Validate new name because}
  8823.   V := FileExpand(@New, NewName, fcDirectory + fcCasePreserve);
  8824.   if DosError <> deNoError                       { DOS Rename function will }
  8825.    then goto Done;                               { just truncate a too-long }
  8826.   StrLCopy(@Names^.Old, OldName, fsNetName);     { filename & return OK!!!  }
  8827.   StrCopy(@Names^.New, NewName);
  8828.   Regs.DS := DosBuf.RealSeg;
  8829.   Regs.ES := DosBuf.RealSeg;
  8830.   Regs.DI := SizeOf(TRename) div 2;              { ES:DI = @Names.NewName   }
  8831.   Regs.AH := $56;                                { DOS - Rename File        }
  8832.   {$ifdef LongNames}
  8833.   if V^.Attributes and vaDosLongNames <> 0
  8834.    then Regs.AX := $7156;                        { LFN - Rename file        }
  8835.   {$endif LongNames}
  8836.   DosError := MsDos(Regs);
  8837.   if Regs.Flags and fCarry = 0
  8838.    then DosError := 0
  8839.    else GetExtError;
  8840. Done:
  8841.   RestoreDosBuf(SaveBuf, SizeOf(SaveBuf));
  8842. end;
  8843. {$endif TurboLong}
  8844.  
  8845. {************************* File Handle based functions *********************}
  8846.  
  8847. function FileGetTime(Handle: Word): Longint;
  8848. {$ifdef TurboDos} assembler;
  8849. asm
  8850.             mov   ax,$5700
  8851.             mov   bx,[Handle]
  8852.             int   intDos
  8853.             mov   bx,0
  8854.             jnc   @@NoError
  8855.             call  GetExtError
  8856.             xor   cx,cx
  8857.             xor   dx,dx
  8858. @@NoError:  mov   [DosError],bx
  8859.             mov   ax,cx
  8860. end;
  8861. {$else TurboDos}
  8862. var
  8863.   Regs: TRegisters;
  8864. begin
  8865.   ClearRegs(Regs);
  8866.   Regs.BX := Handle;
  8867.   Regs.AX := $5700;                    { DOS - Get file date and time       }
  8868.   Regs.Flags := fCarry;
  8869.   DosError := MsDos(Regs);
  8870.   if Regs.Flags and fCarry = 0
  8871.    then DosError := 0
  8872.    else GetExtError;
  8873.   FileGetTime := LongMake(Regs.DX, Regs.CX);
  8874. end;
  8875. {$endif TurboDos}
  8876.  
  8877. procedure FileSetTime(Handle: Word; Time: Longint);
  8878. {$ifdef TurboDos} assembler;
  8879. asm
  8880.             mov     [DosError],0
  8881.             mov     cx,[LongRec(Time).Lo]
  8882.             mov     dx,[LongRec(Time).Hi]
  8883.             mov     ax,$5701           { DOS - Set file date and time       }
  8884.             mov     bx,[Handle]
  8885.             int     intDos
  8886.             jnc     @@Exit
  8887.             call    GetExtError
  8888. @@Exit:
  8889. end;
  8890. {$else TurboDos}
  8891. var
  8892.   Regs: TRegisters;
  8893. begin
  8894.   ClearRegs(Regs);
  8895.   Regs.BX := Handle;
  8896.   Regs.CX := LongRec(Time).Lo;
  8897.   Regs.DX := LongRec(Time).Hi;
  8898.   Regs.AX := $5701;                    { DOS - Set file date and time       }
  8899.   DosError:= MsDos(Regs);
  8900.   if Regs.Flags and fCarry = 0
  8901.    then DosError := 0
  8902.    else GetExtError;
  8903. end;
  8904. {$endif TurboDos}
  8905.  
  8906. function FileOpen(const Name: String; Mode: Word): TFileHandle;
  8907. var
  8908.   Path: array[0..High(String)] of Char;
  8909. begin
  8910.   PasToNull(Name, @Path);
  8911.   FileOpen := FileOpenStr(@Path, Mode);
  8912. end;
  8913.  
  8914. function FileOpenStr(Name: PChar; Mode: Word): TFileHandle;
  8915. var
  8916.   Regs   : TRegisters;
  8917.   V      : PVolumeInfo;
  8918. {$ifndef TurboLong}
  8919.   SaveBuf: TPathNet;
  8920.   Path   : PChar absolute DosBuf;
  8921.   ErrStr : String[5];
  8922. {$endif !TurboLong}
  8923. label
  8924.   Error;
  8925. begin
  8926.   FileOpenStr := TFileHandle(-1);
  8927.   ClearRegs(Regs);
  8928. {$ifdef TurboLong}
  8929.   Regs.DS := PtrRec(Name).Seg;         { No Need to use DosBuf - Just set   }
  8930.   Regs.DX := PtrRec(Name).Ofs;         { Regs.DS:DX to @File_Name (for DOS) }
  8931. {$else TurboLong}
  8932.   CheckDosBuf(SaveBuf, SizeOf(SaveBuf));
  8933.   Regs.DS := DosBuf.RealSeg;           { Regs.DS:SI and DS:DX = @Name       }
  8934.   StrLCopy(Path, Name, fsNetPath);     { Copy Filename into DosBuf          }
  8935. {$endif TurboLong}
  8936.   Regs.AX := Mode;
  8937.   if WordRec(Mode).Hi - $3C > 1 then   { Mode.Hi must be $3C or $3D         }
  8938.    begin
  8939.      DosError := deInvalidfunc;
  8940.      goto Error;
  8941.    end;
  8942. {$ifdef LongNames}
  8943.   V := GetVolumeFromPath(Name);        { See if LFN functions are supported }
  8944.   if V = nil                           { by the target drive                }
  8945.    then goto Error;
  8946.   if V^.Attributes and vaDosLongNames <> 0 then
  8947.    begin
  8948.   {$ifdef TurboLong}
  8949.      Regs.SI := Regs.DX;               { Regs.DS:SI = @File_Name for LFN    }
  8950.   {$endif TurboLong}
  8951.      if WordRec(Mode).Hi = $3C         { Create file                        }
  8952.       then begin
  8953.              Regs.DX := $12;           { Create new file or truncate old    }
  8954.              Mode := Mode or $02;      { Allow read/write access.           }
  8955.            end
  8956.       else Regs.DX := $01;             { Open file - fail if not exist      }
  8957.      Regs.BL := WordRec(Mode).Lo;      { Access and sharing flags           }
  8958.      Regs.AX := $716C;                 { LFN - Open or create file          }
  8959.    end;
  8960. {$endif LongNames}
  8961.   DosError := MsDos(Regs);
  8962.   if Regs.Flags and fCarry = 0
  8963.    then begin
  8964.           FileOpenStr := Regs.AX;      { Return file handle                 }
  8965.           DosError := 0;
  8966.         end
  8967.    else GetExtError;
  8968. Error:
  8969. {$ifndef TurboLong}
  8970.   RestoreDosBuf(SaveBuf, SizeOf(SaveBuf));
  8971. {$endif !TurboLong}
  8972. end;
  8973.  
  8974. procedure FileClose(Handle: TFileHandle);
  8975. {$ifdef TurboDos} assembler;
  8976. asm
  8977.             mov   bx,[Handle]
  8978.             mov   ah,$3E
  8979.             int   intDos
  8980.             mov   bx,0
  8981.             jnc   @@Exit
  8982.             call  GetExtError
  8983. @@Exit:     mov   [DosError],bx
  8984. end;
  8985. {$else TurboDos}
  8986. var
  8987.   Regs: TRegisters;
  8988. begin
  8989.   ClearRegs(Regs);
  8990.   Regs.BX := Handle;
  8991.   Regs.AH := $3E;
  8992.   DosError := MsDos(Regs);
  8993.   if Regs.Flags and fCarry = 0
  8994.    then DosError := 0
  8995.    else GetExtError;
  8996. end;
  8997. {$endif TurboDos}
  8998.  
  8999. function FilePosition(Handle: TFileHandle): Longint;
  9000. {$ifdef TurboDos} assembler;
  9001. asm
  9002.             mov   bx,[Handle]
  9003.             xor   cx,cx
  9004.             mov   [DosError],0
  9005.             mov   ax,$4200 + skCurrent
  9006.             mov   dx,cx
  9007.             int   intDos
  9008.             jnc   @@Ok
  9009.             call  GetExtError
  9010.             mov   ax,-1
  9011.             cwd
  9012. @@Ok:
  9013. end;
  9014. {$else TurboDos}
  9015. var
  9016.   Regs: TRegisters;
  9017. begin
  9018.   ClearRegs(Regs);
  9019.   Regs.BX := Handle;                        { Use Dos LSeek(0, fsCurPos) to }
  9020.   Regs.AX := $4200 + Ord(skCurrent);        { get the current file position }
  9021.   DosError:= MsDos(Regs);                   { without changing file position}
  9022.   FilePosition := -1;
  9023.   if Regs.Flags and fCarry = 0
  9024.    then begin
  9025.           FilePosition := LongMake(Regs.DX, Regs.AX);
  9026.           DosError := 0;
  9027.         end
  9028.    else GetExtError;
  9029. end;
  9030. {$endif TurboDos}
  9031.  
  9032. function FileSize(Handle: TFileHandle): Longint;
  9033. {$ifdef TurboDos} assembler;
  9034. asm                                           { Save current file position }
  9035.             mov   [DosError],0
  9036.             xor   dx,dx
  9037.             xor   cx,cx
  9038.             mov   bx,[Handle]
  9039.             mov   ax,$4200 + skCurrent
  9040.             int   intDos
  9041.             push  dx
  9042.             push  ax
  9043.             xor   dx,dx
  9044.             xor   cx,cx
  9045.             mov   ax,$4200 + skEnd            { Seek to EOF, returning pos  }
  9046.             int   intDos
  9047.             pop   si
  9048.             pop   cx
  9049.             push  dx
  9050.             push  ax
  9051.             mov   dx,si
  9052.             mov   ax,$4200 + skStart          { Seek to saved file position }
  9053.             int   intDos
  9054.             pop   ax
  9055.             pop   dx
  9056.             jnc   @@Exit
  9057.             call  GetExtError
  9058.             mov   ax,-1
  9059.             cwd
  9060. @@Exit:
  9061. end;
  9062. {$else TurboDos}
  9063. var
  9064.   Regs: TRegisters;
  9065.   Pos : Longint;
  9066. label
  9067.   Error;
  9068. begin
  9069.   ClearRegs(Regs);
  9070.   Regs.BX := Handle;
  9071.   Regs.AX := $4200 + Ord(skCurrent);           { Save current file position }
  9072.   LongRec(Pos).Lo := MsDos(Regs);
  9073.   if Regs.Flags and fCarry <> 0
  9074.    then goto Error;
  9075.   LongRec(Pos).Hi := Regs.DX;
  9076.   ClearRegs(Regs);
  9077.   Regs.AX := $4200 + Ord(skEnd);               { Seek to end of file        }
  9078.   Regs.BX := Handle;                           { returns position of EOF    }
  9079.   MsDos(Regs);
  9080.   if Regs.Flags and fCarry <> 0
  9081.    then goto Error;
  9082.   FileSize := LongMake(Regs.DX, Regs.AX);
  9083.   ClearRegs(Regs);
  9084.   Regs.AX := $4200 + Ord(skStart);             { Seek to saved file position}
  9085.   Regs.BX := Handle;
  9086.   Regs.DX := LongRec(Pos).Lo;
  9087.   Regs.CX := LongRec(Pos).Hi;
  9088.   MsDos(Regs);
  9089.   if Regs.Flags and fCarry <> 0
  9090.    then goto Error;
  9091.   Regs.AX := 0;
  9092.  Error:
  9093.   DosError := Regs.AX;
  9094.   if DosError <> 0  then
  9095.    begin
  9096.      GetExtError;
  9097.      FileSize := -1;
  9098.    end;
  9099. end;
  9100. {$endif TurboDos}
  9101.  
  9102. function FileSeek(Handle: TFileHandle; Pos: Longint; SeekType: TFileSeek): Longint;
  9103. {$ifdef TurboDos} assembler;
  9104. asm
  9105.             mov   [DosError],0
  9106.             mov   ah,$42
  9107.             mov   bx,[Handle]
  9108.             mov   dx,Pos.Word[0]               { Pos goes in CX:DX          }
  9109.             mov   cx,Pos.Word[2]
  9110.             mov   al,[SeekType]
  9111.             int   intDos                       { Abs pos returned in DX:AX  }
  9112.             jnc   @@Ok
  9113.             call  GetExtError
  9114.             mov   ax,-1
  9115.             mov   dx,ax
  9116. @@Ok: 
  9117. end;
  9118. {$else TurboDos}
  9119. var
  9120.   Regs: TRegisters;
  9121. begin
  9122.   ClearRegs(Regs);
  9123.   Regs.AH := $42;                              { Seek to given file position}
  9124.   Regs.AL := Ord(SeekType);
  9125.   Regs.BX := Handle;
  9126.   Regs.DX := LongRec(Pos).Lo;
  9127.   Regs.CX := LongRec(Pos).Hi;
  9128.   DosError:= MsDos(Regs);
  9129.   FileSeek := -1;
  9130.   if Regs.Flags and fCarry = 0
  9131.    then begin
  9132.           FileSeek:= LongMake(Regs.DX, Regs.AX); { Abs pos retrnd in DX:AX  }
  9133.           DosError := 0
  9134.         end
  9135.    else GetExtError;
  9136. end;
  9137. {$endif TurboDos}
  9138.  
  9139. function FileRead(Handle: TFileHandle; var Buf; Count: Word): Word;
  9140. {$ifdef TurboDos} assembler;
  9141. asm
  9142.             push  ds
  9143.             mov   [DosError],0
  9144.             lds   dx,[Buf]
  9145.             mov   cx,[Count]
  9146.             mov   bx,[Handle]
  9147.             mov   ah,$3F
  9148.             int   intDos
  9149.             pop   ds
  9150.             jnc   @@Ok
  9151.             call  GetExtError
  9152.             les   si,[Buf]
  9153.             xor   ax,ax
  9154.             mov   cx,[Count]
  9155.             cld
  9156.             rep   stosb
  9157. @@Ok:
  9158. end;
  9159. {$else TurboDos}
  9160. var
  9161.   Regs : TRegisters;
  9162.   T    : TByteArray absolute Buf;
  9163.   S    : PByteArray absolute DosBuf;
  9164.   J,C,R: Word;
  9165. begin
  9166.   FileRead := 0;
  9167.   if (DosBuf.Size < 512) and not DosInit then
  9168.    begin
  9169.      DosError := deBadMemBlock;
  9170.      FillChar(Buf, Count, 0);
  9171.      Exit;
  9172.    end;
  9173.   J := 0;
  9174.   R := 0;
  9175.   ClearRegs(Regs);
  9176.   Regs.DS := DosBuf.RealSeg;
  9177.   DosError := 0;
  9178.   Regs.BX := Handle;
  9179.   while Count <> 0 do
  9180.    begin
  9181.      C := MinWord(Count, DosBuf.Size);;
  9182.      Regs.CX := C;
  9183.      Regs.AH := $3F;
  9184.      MsDos(Regs);
  9185.      if Regs.Flags and fCarry <> 0 then
  9186.       begin
  9187.         FillChar(T[J], Count, 0);
  9188.         DosError := Regs.AX;
  9189.         GetExtError;
  9190.         Break;
  9191.       end;
  9192.      Move(S^, T[j], Regs.AX);
  9193.      Inc(J, Regs.AX);
  9194.      Dec(Count, Regs.AX);
  9195.      Inc(R, Regs.AX);
  9196.      if Regs.AX <> C
  9197.       then Break;
  9198.    end;
  9199.   FileRead := R;
  9200. end;
  9201. {$endif TurboDos}
  9202.  
  9203. function FileWrite(Handle: TFileHandle; const Buf; Count: Word): Word;
  9204. {$ifdef TurboDos} assembler;
  9205. asm
  9206.             mov   cx,[Count]
  9207.             mov   [DosError],0
  9208.             jcxz  @@1
  9209.             push  ds
  9210.             lds   dx,[Buf]
  9211.             mov   bx,[Handle]
  9212.             mov   ah,$40
  9213.             int   intDos
  9214.             pop   ds
  9215.             jnc   @@2
  9216.             call  GetExtError
  9217. @@1:        xor   ax,ax
  9218. @@2:
  9219. end;
  9220. {$else TurboDos}
  9221. var
  9222.   Regs : TRegisters;
  9223.   S    : TByteArray absolute Buf;
  9224.   T    : PByteArray absolute DosBuf;
  9225.   j,C,R: Word;
  9226. begin
  9227.   FileWrite := 0;
  9228.   if (Count = 0) or ((DosBuf.Size < 512) and not DosInit)
  9229.    then Exit;
  9230.   j := 0;
  9231.   R := 0;
  9232.   ClearRegs(Regs);
  9233.   Regs.DS := DosBuf.RealSeg;
  9234.   DosError := 0;
  9235.   Regs.BX := Handle;
  9236.   while Count <> 0 do
  9237.    begin
  9238.      C := MinWord(Count, DosBuf.Size);
  9239.      Move(S[j], T^, C);
  9240.      Regs.AH := $40;
  9241.      Regs.CX := C;
  9242.      MsDos(Regs);
  9243.      if Regs.Flags and fCarry <> 0 then
  9244.       begin
  9245.         DosError := Regs.AX;
  9246.         GetExtError;
  9247.         Break;
  9248.       end;
  9249.      Inc(j, Regs.AX);
  9250.      Dec(Count, Regs.AX);
  9251.      Inc(R, Regs.AX);
  9252.      if Regs.AX <> C
  9253.       then Break;
  9254.    end;
  9255.   FileWrite := R;
  9256. end;
  9257. {$endif TurboDos}
  9258.  
  9259. procedure FileTruncate(Handle: TFileHandle);
  9260. {$ifdef TurboDos} assembler;
  9261. asm
  9262.             xor   cx,cx
  9263.             mov   bx,[Handle]
  9264.             mov   [DosError],cx
  9265.             mov   ah,$40
  9266.             mov   [DosError],cx
  9267.             int   intDos
  9268.             jnc   @@Ok
  9269.             call  GetExtError
  9270. @@Ok:
  9271. end;
  9272. {$else TurboDos}
  9273. var
  9274.   Regs: TRegisters;
  9275. begin
  9276.   ClearRegs(Regs);
  9277.   Regs.BX := Handle;
  9278.   Regs.AH := $40;
  9279.   DosError := MsDos(Regs);
  9280.   if Regs.Flags and fCarry = 0
  9281.    then DosError := 0
  9282.    else GetExtError;
  9283. end;
  9284. {$endif TurboDos}
  9285.  
  9286. {-------------------------- Case conversion functions ----------------------}
  9287.  
  9288. procedure DosUpperCase(var S: String); assembler;
  9289. asm
  9290.             les   di,[S]
  9291.             xor   cx,cx
  9292.             xor   bx,bx
  9293.             mov   cl,[es:di]
  9294.             inc   di
  9295.             jcxz  @@Exit
  9296. @@Next:     mov   bl,[es:di]
  9297.             inc   di
  9298.             mov   al,[bx+offset LoToUpTbl]
  9299.             dec   cx
  9300.             mov   [es:di-1],al
  9301.             jnz   @@Next
  9302. @@Exit:
  9303. end;
  9304.  
  9305. procedure DosLowerCase(var S: String); assembler;
  9306. asm
  9307.             les   di,[S]
  9308.             xor   cx,cx
  9309.             xor   bx,bx
  9310.             mov   cl,[es:di]
  9311.             inc   di
  9312.             jcxz  @@Exit
  9313. @@Next:     mov   bl,[es:di]
  9314.             inc   di
  9315.             mov   al,[bx+offset UpToLoTbl]
  9316.             dec   cx
  9317.             mov   [es:di-1],al
  9318.             jnz   @@Next
  9319. @@Exit:
  9320. end;
  9321.  
  9322. function StrUpper(Str: PChar): PChar; assembler;
  9323. asm
  9324.             les   di,[Str]
  9325.             xor   cx,cx
  9326.             mov   ax,es
  9327.             xor   bx,bx
  9328.             or    ax,di
  9329.             jz    @@Exit
  9330.  
  9331. @@Next:     mov   bl,[es:di]
  9332.             inc   di
  9333.             or    bx,bx
  9334.             mov   al,[bx+offset LoToUpTbl]
  9335.             mov   [es:di-1],al
  9336.             jnz   @@Next
  9337. @@Exit:     mov   dx,es
  9338.             mov   di,[Str].Word[0]
  9339. end;
  9340.  
  9341. function StrLower(Str: PChar): PChar; assembler;
  9342. asm
  9343.             les   di,[Str]
  9344.             xor   cx,cx
  9345.             mov   ax,es
  9346.             xor   bx,bx
  9347.             or    ax,di
  9348.             jz    @@Exit
  9349.  
  9350. @@Next:     mov   bl,[es:di]
  9351.             inc   di
  9352.             or    bx,bx
  9353.             mov   al,[bx+offset UpToLoTbl]
  9354.             mov   [es:di-1],al
  9355.             jnz   @@Next
  9356. @@Exit:     mov   dx,es
  9357.             mov   di,[Str].Word[0]
  9358. end;
  9359.  
  9360. {------------------ Programmable Interrupt Timer functions -----------------}
  9361.  
  9362. function GetPit0Count: Word; assembler;
  9363. asm
  9364.             xor   ax,ax
  9365.             cli
  9366.             out   pitCtrl,al
  9367.             in    al,pitTimer0
  9368.             shl   ax,8
  9369.             in    al,pitTimer0
  9370.             xchg  al,ah
  9371.             sti
  9372. end;
  9373.  
  9374. function GetPit1Count: Word; assembler;
  9375. asm
  9376.             mov   al,2
  9377.             cli
  9378.             out   pitCtrl,al
  9379.             in    al,pitTimer1
  9380.             shl   ax,8
  9381.             in    al,pitTimer1
  9382.             xchg  al,ah
  9383.             sti
  9384. end;
  9385.  
  9386. function GetPit2Count: Word; assembler;
  9387. asm
  9388.             xor   ax,ax
  9389.             cli
  9390.             out   pitCtrl,al
  9391.             in    al,pitTimer2
  9392.             shl   ax,8
  9393.             in    al,pitTimer2
  9394.             xchg  al,ah
  9395.             sti
  9396. end;
  9397.  
  9398. procedure SetPit0Mode(Mode: Word; Value: Word); assembler;
  9399. asm
  9400.             mov   ax,[Mode]
  9401.             cmp   ax,6
  9402.             ja    @@Exit
  9403.             shl   ax,1
  9404.             add   al,$30
  9405.             cli
  9406.             out   pitCtrl,al
  9407.             mov   ax,[Value]
  9408.             out   pitTimer0,al
  9409.             shr   ax,8
  9410.             out   pitTimer0,al
  9411.             sti
  9412. @@Exit:
  9413. end;
  9414.  
  9415. function GetPit0Mode: Word;
  9416. begin
  9417.   Port[pitCtrl] := $C2;                         { Readback command is only  }
  9418.   GetPit0Mode := (Port[pitTimer0] and $E) shr 1;{ possible with the 8254 !  }
  9419. end;
  9420.  
  9421. function GetPitType: Word;
  9422.  
  9423.   function GetPITValue(Channel: Byte): Word;
  9424.   var
  9425.     j: Word;
  9426.   begin
  9427.     Port[pitCtrl] := Channel shl 6;
  9428.     j := Port[pitTimer0 + Channel];
  9429.     j := Port[pitTimer0 + Channel] shl 8 + j;
  9430.     GetPITValue := j;
  9431.   end;
  9432.  
  9433. const
  9434.   testValue = $55AA;
  9435.   backwards = Lo(TestValue) shl 8 + Hi(TestValue);
  9436.   expCntStatus = $30;                             { Expected counter status }
  9437. var
  9438.   Port61     : Byte;
  9439.   PitType    : Byte;
  9440.   RdbStatus1 : Byte;
  9441.   RdbStatus2 : Byte;
  9442.   RdbCount1  : Word;
  9443.   RdbCount2  : Word;
  9444.   i,j        : Word;
  9445. label
  9446.   GotType;
  9447. begin
  9448.   PitType := pitEmulated;
  9449.   DisableInterrupts;
  9450.  
  9451.   { Turn off speaker & set gate2 input to low }
  9452.  
  9453.   Port61 := Port[$61];
  9454.   Port[$61] := Port61 and $FC;
  9455.  
  9456.   { Program channel 2 to mode 0, two bytes, binary }
  9457.  
  9458.   Port[$43] := $B0;
  9459.   Port[$42] := Lo(TestValue);
  9460.   Port[$42] := Hi(TestValue);
  9461.  
  9462.   { Wait until the value of counter 0 changes }
  9463.  
  9464.   i := GetPitValue(0);
  9465.   repeat
  9466.     j := GetPitValue(0);
  9467.   until i <> j;
  9468.  
  9469.   repeat
  9470.   until j <> GetPitValue(0);
  9471.  
  9472.   { Read value from counter 2, test if readout is stable }
  9473.  
  9474.   i := GetPitValue(2);
  9475.   j := GetPitValue(2);
  9476.  
  9477.   { if not then the PIT is bad or emulated }
  9478.  
  9479.   if (i <> j) or (i <> TestValue)
  9480.    then goto GotType;
  9481.  
  9482.   { Readback command will reverse lo/hi flag on a 8053 }
  9483.  
  9484.   Port[pitCtrl]  := $C8;
  9485.   RdbStatus1 := Port[pitTimer2];
  9486.   RdbCount1  := Port[pitTimer2];
  9487.   RdbCount1  := (Port[pitTimer2] shl 8) + RdbCount1;
  9488.  
  9489.   i := GetPitValue(2);
  9490.  
  9491.   { Read again to fix hi/lo flag }
  9492.  
  9493.   Port[pitCtrl] := $C8;
  9494.   RdbStatus2 := Port[pitTimer2];
  9495.   RdbCount2  := Port[pitTimer2];
  9496.   RdbCount2  := (Port[pitTimer2] shl 8) + RdbCount2;
  9497.  
  9498.   j := GetPitValue (2);
  9499.  
  9500.   if (RdbStatus1 <> expCntStatus) and (RdbStatus2 <> expCntStatus) and
  9501.      (i = backwards) and (j = TestValue)
  9502.    then PitType := pit8253
  9503.    else if (RdbStatus1 = expCntStatus) and (RdbStatus2 = expCntStatus) and
  9504.            (i = TestValue) and (j = TestValue)
  9505.          then PitType := pit8254;
  9506.  
  9507. GotType:
  9508.   EnableInterrupts;
  9509.   GetPitType := PitType;
  9510. end;
  9511.  
  9512. {-------------------------- Unit initialization code -----------------------}
  9513.  
  9514. type
  9515.   PObject = ^TObject;
  9516.   TObject = object
  9517.     destructor Done; virtual;
  9518.   end;
  9519.  
  9520. destructor TObject.Done;
  9521. begin
  9522. end;
  9523.  
  9524. function DisposeVolume(V: PVolumeInfo): PVolumeInfo;
  9525. begin
  9526.   DisposeVolume := nil;
  9527.   if V = nil
  9528.    then Exit;
  9529.   DisposeVolume := V^.Next;
  9530.   if V^.VmtOffset <> 0
  9531.    then Dispose(PObject(V), Done)
  9532.    else begin
  9533.           DisposeStr(PString(V^.NetName));
  9534.           Dispose(V);
  9535.         end;
  9536. end;
  9537.  
  9538. function DosInit: Boolean;
  9539. var
  9540.   Regs: TRegisters;
  9541. begin
  9542.   DosInit := true;
  9543.   if DosBufSize <> DosBuf.Size then
  9544.    begin
  9545.      FreeDosMem(DosBuf);         { Release any previous DOS transfer buffer }
  9546.      DosInit := GetDosMem(DosBuf, DosBufSize); { Allocate DOS xfer buffer   }
  9547.      FillChar(DosBuf.Buf^, DosBuf.Size, 0);
  9548.      ClearRegs(Regs);
  9549.      Regs.AH := $2F;                   { MsDos - Get Disk Transfer Address  }
  9550.      MsDos(Regs);
  9551.      SaveDTA := Ptr(Regs.ES, Regs.BX);
  9552.      Regs.AH := $1A;                   { MsDos - Set Disk Transfer Address  }
  9553.      Regs.DS := DosBuf.RealSeg;        { DTA = DosBuf.RealSeg:$0000         }
  9554.      Regs.DX := 0;
  9555.      MsDos(Regs);
  9556.    end;
  9557. end;
  9558.  
  9559. procedure DosDone;
  9560. var
  9561.   Regs: TRegisters;
  9562.   V   : PVolumeInfo;
  9563. begin
  9564.   V := VolumeList;                     { Destroy all volume info records    }
  9565.   repeat
  9566.     V := DisposeVolume(V);
  9567.   until V = nil;
  9568.   VolumeList := nil;
  9569.   if SaveDTA <> nil then               { Restore DTA to previous address    }
  9570.    begin
  9571.      ClearRegs(Regs);
  9572.      Regs.AH := $1A;                   { MsDos - Set Disk Transfer Address  }
  9573.      Regs.DS := PtrRec(SaveDTA).Seg;
  9574.      Regs.DX := PtrRec(SaveDTA).Ofs;
  9575.      MsDos(Regs);
  9576.    end;
  9577.   FreeDosMem(DosBuf);                  { Release DOS transfer buffer        }
  9578. end;
  9579.  
  9580. {---------------------------------------------------------------------------}
  9581. {                                                                           }
  9582. {                        System Unit hooking code                           }
  9583. {                                                                           }
  9584. {---------------------------------------------------------------------------}
  9585.  
  9586. type
  9587.   TPatchCode = record
  9588.     OpCode: Byte;
  9589.     Addr  : Pointer;
  9590.   end;
  9591.  
  9592.   TPatch = record
  9593.     Old: Pointer;
  9594.     New: Pointer;
  9595.   end;
  9596.  
  9597.   PatchType = (paMkDir, paRmDir, paChDir, paGetDir, paFRewrite, paErase,
  9598.                paRename, paAssignText, paAssignFile, paFClose
  9599. {$ifndef TurboDos},
  9600.                paBlockWrite, paBlockRead, paFileSeek, paFilePos,
  9601.                paFileRead, paFileWrite
  9602. {$endif !TurboDos}
  9603.   );
  9604. const
  9605.   Patches: array[PatchType] of TPatch = (
  9606.     (Old: nil;       New: @LfnMkDir),
  9607.     (Old: nil;       New: @LfnRmDir),
  9608.     (Old: nil;       New: @GDos.ChDir),
  9609.     (Old: nil;       New: @LfnGetDir),
  9610.     (Old: Ptr(0,6);  New: @LfnOpenFile),    { For ResetFile and ReWriteFile }
  9611.     (Old: nil;       New: @LfnErase),
  9612.     (Old: Ptr(0,2);  New: @LfnRename),
  9613.     (Old: Ptr(0,4);  New: @LfnAssignText),
  9614.     (Old: Ptr(0,4);  New: @LfnAssignFile),
  9615.     (Old: nil;       New: @LfnCloseFile)
  9616. {$ifndef TurboDos},
  9617.     (Old: nil;       New: @BlockWrite),
  9618.     (Old: nil;       New: @BlockRead),
  9619.     (Old: nil;       New: @SeekFile),
  9620.     (Old: nil;       New: @FilePos),
  9621.     (Old: nil;       New: @LfnFileRead),
  9622.     (Old: nil;       New: @LfnFileWrite)
  9623. {$endif !TurboDos}
  9624.     );
  9625.  
  9626. procedure HookSystemCalls;
  9627. label
  9628.   lMkDir, lRmDir, lChDir, lGetDir, lFRewrite, lErase, lRename, lAssignText,
  9629.   lAssignFile, lFClose,
  9630. {$ifndef TurboDos}
  9631.   lBlockWrite, lBlockRead, lSeekFile, lFilePos, lFileRead, lFileWrite,
  9632. {$endif !TurboDos}
  9633.   Start;
  9634. var
  9635.   S : String[1];
  9636.   F : file;
  9637.   TF: file of byte absolute F;
  9638.   T : Text;
  9639.   W : Word;
  9640.   B : Byte absolute W;
  9641.   L : Longint;
  9642.   P : PChar;
  9643.   i : PatchType;
  9644.   Patch: TPatchCode;
  9645.   Selector: Word;
  9646. begin
  9647.   goto Start;
  9648.  
  9649. { These standard functions are replaced because they are not LFN-capable }
  9650. { and/or they need a DOS extender to work.                               }
  9651.  
  9652.   System.MkDir(''); lMkDir:
  9653.   System.RmDir(''); lRmDir:
  9654.   System.ChDir(''); lChDir:
  9655.   System.GetDir(0, S); lGetDir:
  9656.   System.Rewrite(F,1); lFRewrite:
  9657.   System.Erase(F); lErase:
  9658.   System.Rename(F, S); lRename:
  9659.   System.Assign(T, S); lAssignText:
  9660.   System.Assign(F, S); lAssignFile:
  9661.   System.Close(F); lFClose:
  9662.  
  9663. {$ifndef TurboDos}
  9664.  
  9665. { These standard functions are replaced because they need a DOS Extender }
  9666.  
  9667.   System.BlockWrite(F, W, 1, W); lBlockWrite:
  9668.   System.BlockRead(F, W, 1, W); lBlockRead:
  9669.   System.Seek(F, 0); lSeekFile:
  9670.   L := System.FilePos(F); lFilePos:
  9671.   System.Read(TF, B); lFileRead:
  9672.   System.Write(TF, B); lFileWrite:
  9673.  
  9674. {$endif !TurboDos}
  9675. asm
  9676. @@StorePtr:
  9677.       shl     si,3                { SI = Index into Patches Array           }
  9678.       sub     bx,4                { Position of the CALL FAR                }
  9679.       lea     di,Patches[si]      { DS:DI = @Patches[BX].Old                }
  9680.       mov     ax,cs:[bx]          { AX = Offset of the CALL FAR address     }
  9681.       add     [di],ax             { Add adjust and Store ofs(SystemFuncXXXX)}
  9682.       mov     ax,cs:[bx+2]        { Store segment of System function        }
  9683.       mov     [di+2],ax
  9684.       retn
  9685.  
  9686. Start:
  9687.       mov     si,paMkDir
  9688.       mov     bx,offset lMkDir
  9689.       call    @@StorePtr
  9690.  
  9691.       mov     si,paRmDir
  9692.       mov     bx,offset lRmDir
  9693.       call    @@StorePtr
  9694.  
  9695.       mov     si,paChDir
  9696.       mov     bx,offset lChDir
  9697.       call    @@StorePtr
  9698.  
  9699.       mov     si,paGetDir
  9700.       mov     bx,offset lGetDir
  9701.       call    @@StorePtr
  9702.  
  9703.       mov     si,paFRewrite
  9704.       mov     bx,offset lFRewrite
  9705.       call    @@StorePtr
  9706.  
  9707.       mov     si,paErase
  9708.       mov     bx,offset lErase
  9709.       call    @@StorePtr
  9710.  
  9711.       mov     si,paRename
  9712.       mov     bx,offset lRename
  9713.       call    @@StorePtr
  9714.  
  9715.       mov     si,paAssignText
  9716.       mov     bx,offset lAssignText
  9717.       call    @@StorePtr
  9718.  
  9719.       mov     si,paAssignFile
  9720.       mov     bx,offset lAssignFile
  9721.       call    @@StorePtr
  9722.  
  9723.       mov     si,paFClose
  9724.       mov     bx,offset lFClose
  9725.       call    @@StorePtr
  9726.  
  9727. {$ifndef TurboDos}
  9728.       mov     si,paBlockWrite
  9729.       mov     bx,offset lBlockWrite
  9730.       call    @@StorePtr
  9731.  
  9732.       mov     si,paBlockread
  9733.       mov     bx,offset lBlockRead
  9734.       call    @@StorePtr
  9735.  
  9736.       mov     si,paFileSeek
  9737.       mov     bx,offset lSeekFile
  9738.       call    @@StorePtr
  9739.  
  9740.       mov     si,paFilePos
  9741.       mov     bx,offset lFilePos - 8
  9742.       call    @@StorePtr
  9743.  
  9744.       mov     si,paFileRead
  9745.       mov     bx,offset lFileRead - 3
  9746.       call    @@StorePtr
  9747.  
  9748.       mov     si,paFileWrite
  9749.       mov     bx,offset lFileWrite - 3
  9750.       call    @@StorePtr
  9751. {$endif !TurboDos}
  9752.     end;
  9753.   Patch.OpCode := $EA;                      { Machine opcode for JMP FAR    }
  9754. {$ifdef Windows}
  9755.   Selector := AllocSelector(0);
  9756. {$endif}
  9757.   for i := Low(Patches) to High(Patches) do
  9758.    begin
  9759.      Patch.Addr := Patches[i].New;          { Where we want to jump to      }
  9760.  {$ifdef DPMI}
  9761.      Inc(PtrRec(Patches[i].Old).Seg,        { Where we want to jump from,   }
  9762.          SelectorInc);                      { converted to a DATA selector  }
  9763.  {$endif DPMI}
  9764.  {$ifdef Windows}
  9765.      ChangeSelector(CSeg, Selector);        { Ensure a read/write selector }
  9766.      PtrRec(Patches[i].Old).Seg := Selector;
  9767.  {$endif Windows}
  9768.      Move(Patch, Patches[i].Old^, SizeOf(Patch));   { Insert the "hook"     }
  9769.    end;
  9770. {$ifdef Windows}
  9771.   FreeSelector(Selector);
  9772. {$endif}
  9773.   Assign(OutPut, '');                       { Make the standard files use   }
  9774.   Rewrite(Output);                          { the GDOS "Text" functions     }
  9775.   Assign(Input, '');
  9776.   Reset(Input);
  9777. end;
  9778.  
  9779. { Return the uppercase version of the character passed in Ch using the   }
  9780. { Country dependant information upper case map function                  }
  9781.  
  9782. function CaseMapUpCh(InCh:Char):Char; assembler;
  9783. {$ifndef DPMI}
  9784. asm
  9785.             mov   al,[InCh]
  9786.             call  [DosCountry.UpCase]
  9787. end;
  9788. {$else !DPMI}
  9789. var
  9790.   Regs: TRegisters;
  9791. asm
  9792.             push  ss
  9793.             lea   di,Regs
  9794.             pop   es                        { ES:DI = @RealRegs             }
  9795.             cld
  9796.             mov   cx,type TRegisters/2      { Zero all Registers            }
  9797.             xor   ax,ax
  9798.             mov   dx,[word ptr DosCountry.UpCase]
  9799.             rep   stosw
  9800.  
  9801.             mov   bx,[word ptr DosCountry.UpCase+2]   { CX is now 0         }
  9802.             mov   [Regs.&IP],dx             { Regs.CS:IP = Country.UpCase   }
  9803.             mov   al,[InCh]
  9804.             mov   [Regs.&CS],bx
  9805.             mov   [Regs.&AX],ax             { Regs.AL = InCh                }
  9806.             lea   di,Regs                   { ES:DI = @Regs                 }
  9807.             xor   bx,bx                     { BH and CX must equal 0        }
  9808.             mov   ax,dpmiCallRealFar        { Simulate real-mode far call   }
  9809.             int   intDPMI
  9810.             mov   ax,[Regs.&AX]
  9811. end;
  9812. {$endif !DPMI}
  9813.  
  9814. function InitCountry: Boolean;
  9815. var
  9816.   L,U  : Char;
  9817.   Regs : TRegisters;
  9818.   Buf  : TDosBuf;
  9819.   CDI  : ^TDosCountry absolute Buf;
  9820. begin
  9821.   InitCountry := False;
  9822.   if not GetDosMem(Buf, SizeOf(TDosCountry))
  9823.    then Exit;
  9824.   ClearRegs(Regs);
  9825.   Regs.AX := $3800;          { DOS - Get country dependant information      }
  9826.   Regs.DS := Buf.RealSeg;    { DOS function $3800 requires the address of a }
  9827.   Regs.DX := Buf.RealOfs;    { TDosCountry structure to be passed in DS:DX  }
  9828.   MsDos(Regs);               { Call DOS function $3800                      }
  9829.   DosCountry := CDI^;        { Copy country info to permanent buffer.       }
  9830.   DosCountry.CountryCode := Regs.BX;
  9831.   FreeDosMem(Buf);
  9832.   if not Assigned(DosCountry.UpCase)
  9833.    then Exit;
  9834.   DosCountry.CurrencyStr := NullToPas(@DosCountry.CurrencyStr);
  9835.   for L := #128 to #255 do
  9836.    begin
  9837.      U := CaseMapUpCh(L);    { Get the uppercase equivalent of L            }
  9838.      LoToUpTbl[L] := U;      { Store it in the LowerCase->UpperCase table   }
  9839.      if U >= #128            { Store the inverse in the Upper->Lower table  }
  9840.       then UpToLoTbl[U] := L;{ if it's an extended uppercase character      }
  9841.      if L = U                    { add all non-lowercase extended chars to  }
  9842.       then Include(DosChars, U); { set of valid DOS 8.3 filename char set   }
  9843.    end;
  9844. end;
  9845.  
  9846. procedure CalcExeDir;   { Calculate the drive and directory of the program. }
  9847.                         { The EXE path is always terminated with a "\".     }
  9848. begin                   { This procedure means that GV must run on DOS 3.0+ }
  9849.   FSplit(FExpand(ParamStr(0), fcFileName + fcCasePreserve),{ Use FExpand to }
  9850.          ExeDir, ExeName, ExeExt);          { convert short name components }
  9851.   AddDirSep(ExeDir);                        { to their true Long file name  }
  9852. end;
  9853.  
  9854. procedure CheckForLongNames; { Determine LFN support by checking the volume }
  9855. var                          { attributes first of Drive C:, then trying    }
  9856.   C      : Char;             { A: if C: doesn't exist. This should prove    }
  9857.   P      : Char;             { reliable on all PC's, even those where there }
  9858.   Regs   : TRegisters;       { are no functioning hard or network drives.   }
  9859.   LfnInfo: PLfnRootVolInfo absolute DosBuf;
  9860.   SaveBuf: TLfnRootVolInfo;
  9861. begin
  9862.   CheckDosBuf(SaveBuf, SizeOf(SaveBuf));
  9863.   C := 'E';
  9864.   repeat
  9865.     Dec(C, 2);
  9866.     ClearRegs(Regs);
  9867.     Regs.Flags := fCarry;
  9868.     Regs.AX := $71A0;                    { LFN - Get Volume Information     }
  9869.     Regs.CX := SizeOf(TFileSysName);     { CX = SizeOf(LfnInfo.FileSysName) }
  9870.     Regs.DX := SizeOf(TFileSysName);     { DS:DX = @LfnInfo.RootName        }
  9871.     Regs.ES := DosBuf.RealSeg;           { ES:DI = @LfnInfo.FileSysName     }
  9872.     Regs.DS := Regs.ES;
  9873.     PasToNull(C + ':\', @LfnInfo^.RootName);
  9874.     if DriveValid(C) then
  9875.      begin
  9876.        MsDos(Regs);
  9877.        VFat := (Regs.Flags and fCarry = 0) and
  9878.                (Regs.BX and vaDosLongNames <> 0);
  9879.        Break;
  9880.      end;
  9881.   until C = 'A';
  9882.   RestoreDosBuf(SaveBuf, SizeOf(SaveBuf));
  9883. end;
  9884.  
  9885. function Win9xRunning: Boolean; assembler;
  9886. asm
  9887.             mov   ax,$160A
  9888.             int   2Fh
  9889.             or    ax,ax
  9890.             je    @@Yes
  9891. @@No:       mov   al,false
  9892.             jmp   @@Exit
  9893.  
  9894. @@Yes:      cmp   bx,$0395
  9895.             jl    @@No
  9896.             mov   al,true
  9897. @@Exit:
  9898. end;
  9899.  
  9900. {$ifdef DPMI}
  9901. procedure InitHardInt; assembler; { Initialize the hardware interrupt number}
  9902. asm                               { to interrupt vector lookup table.       }
  9903.             mov   ax,dpmiGetInfo
  9904.             int   intDPMI    { Get primary and secondary hardware interrupt }
  9905.             xchg  dl,dh      { DL = Primary offset  DH = Secondary offset   }
  9906.             mov   [word ptr MasterPicBase],dx      { offset values.         }
  9907. end;
  9908.  
  9909. {$else DPMI}
  9910.  
  9911. function NoXmsDriver: WordBool; far; assembler;
  9912. asm
  9913.             xor   ax,ax            { Xms function failed                    }
  9914.             mov   bl,$80           { Xms function not supported             }
  9915. end;
  9916.  
  9917. {= XMSDetect ============================================================}
  9918. { Determines whether XMS is present. If so initialises the driver entry  }
  9919. { point variable, and various state flags & variables. This MUST be      }
  9920. { called before any other XMS routine. After calling XMSInitHeap,        }
  9921. { check the XMSinstalled flag to see whether XMS is available.           }
  9922. {========================================================================}
  9923.  
  9924. procedure XmsDetect; assembler;
  9925. asm
  9926.             mov   ax,$4300         { Perform standard test for XMS driver   }
  9927.             int   $2F
  9928.             sub   al,$80           { AL = 80h => XMS present                }
  9929.             jnz   @@NoXMS          { No XMS, jump out of asm block          }
  9930.             mov   ax,$4310         { XMS present, so get driver entry point }
  9931.             int   $2F
  9932.             mov   [XmsFunc].Word[0],bx
  9933.             mov   [XmsFunc].Word[2],es
  9934.             mov   [XmsInstalled],true
  9935.             mov   ah,xmsGetVersion
  9936.             call  [XmsFunc]
  9937.             mov   [XmsVersion],ax
  9938. {$ifdef XMS30}
  9939.             cmp   ax,$300          { Must be version 3.00 compliant         }
  9940.             jae   @@Exit           { It is, so XMS functions are supported  }
  9941. {$else XMS30}
  9942.             jmp   @@Exit
  9943. {$endif XMS30}
  9944.  
  9945. @@NoXMS:    lea   ax,NoXmsDriver
  9946.             mov   [XmsFunc].Word[0],ax
  9947.             mov   [XmsFunc].Word[2],cs
  9948.             mov   [XmsInstalled],false
  9949. @@Exit:
  9950. end;
  9951.  
  9952. {$endif DPMI}
  9953.  
  9954. var
  9955.   OldExitProc: Pointer;
  9956.  
  9957. procedure GDosExitProc; far;
  9958. var
  9959.   E,J,K : Integer;
  9960.   Suffix: String[3];
  9961. begin
  9962.   ExitProc := OldExitProc;
  9963.  
  9964.   { Erase all auto-erase temporary files created by this application }
  9965.  
  9966.   K := 0;
  9967.   E := DosError;
  9968.   while TempNums <> [] do
  9969.   begin
  9970.     if K in TempNums then
  9971.      begin
  9972.        Exclude(TempNums, K);
  9973.        Str(K, Suffix);                              { Create numeric suffix }
  9974.        for J := Length(Suffix)+1 to High(Suffix) do
  9975.          Suffix := '0' + Suffix;
  9976.        FErase(TempDir^ + TempPrefix + Suffix + '.TMP');
  9977.      end;
  9978.     Inc(K);
  9979.   end;
  9980.   DosError := E;
  9981.  
  9982.   UnHookAll;      { Unhook user installed interrupts and realmode callbacks }
  9983.   DosDone;        { Dispose of heap memory used by GDos                     }
  9984.   DisposeStr(PString(TempDir));
  9985.  
  9986. {$ifdef MsDos}
  9987.  
  9988.   { Releases the XMS block used by the overlay file allocated }
  9989.  
  9990.   if OvrXmsHandle <> 0
  9991.    then FreeXms(OvrXmsHandle);
  9992.   OvrXmsHandle := 0;
  9993. {$endif MsDos}
  9994. end;
  9995.  
  9996. procedure Proc386; assembler;
  9997. asm
  9998.   db 73,13,10,'This program requires a 386 or later processor',13,10
  9999.   db          'Program Terminated.',13,10,13,10
  10000. end;
  10001.  
  10002. procedure Dos33; assembler;
  10003. asm
  10004.   db 66,13,10,'This program requires Dos 3.3 or later.',13,10
  10005.   db          'Program Terminated.',13,10,13,10
  10006. end;
  10007.  
  10008. begin { GDos startup code }
  10009.   if Test8086 < 2 then            { The GDos unit requires a 386 or better  }
  10010.    begin
  10011.      PrintStr(PString(@Proc386)^);
  10012.      RunError(254);               { Unsupported CPU                         }
  10013.    end;
  10014.  
  10015.    asm
  10016.             mov   ax,$3000        { Get the version of DOS that's running   }
  10017.             int   intDos
  10018.             xchg  al,ah
  10019.             mov   [DosVersion],ax
  10020.    end;
  10021.  
  10022.   if DosVersion < $0303 then      { O/S must be DOS must be 3.3 or higher   }
  10023.    begin
  10024.      PrintStr(PString(@Dos33)^);
  10025.      RunError(255);               { Unsupported operating system            }
  10026.    end;
  10027.  
  10028.   InitCountry;                    { Initialize county-dependant information }
  10029.   CreateVolume := StdCreateVolume;{ Assign default TVolumeInfo creator      }
  10030. {$ifdef LongNames}
  10031.   CheckForLongNames;              { Check for an LFN-capable O/S (sets VFAT)}
  10032.   HookSystemCalls;                { Hook System unit calls for LFN & DPMI   }
  10033. {$else LongNames}
  10034. {$ifndef TurboDos}
  10035.   HookSystemCalls;                { Hook System unit calls for DPMI reasons }
  10036. {$endif TurboDos}
  10037. {$endif LongNames}
  10038.   CalcExeDir;                     { Define exe directory, name and extension}
  10039. {$ifdef DPMI}
  10040.   InitHardInt;                    { Set MasterPicBase and SlavePicBase      }
  10041. {$else  DPMI}
  10042.   XmsDetect;
  10043. {$endif DPMI}
  10044.   OldExitProc := ExitProc;        { Chain GDos.ExitProc to exit chain       }
  10045.   ExitProc := @GDosExitProc;
  10046.   DosDone;                        { Deallocate all heap memory used and     }
  10047. end.                              { the exe's volume information record.    }
  10048.