home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / bp7os2 / oscrt4 / dos.pas < prev   
Pascal/Delphi Source File  |  1994-02-11  |  37KB  |  1,334 lines
  1. unit Dos;
  2.  
  3. {$S-,R-,Q-,I-,B-}
  4.  
  5. {**********************************************************}
  6. {                                                          }
  7. { BP4OS2: DOS Interface Unit                               }
  8. {                                                          }
  9. {         Portions of this file                            }
  10. {         Copyright (C) 1988,92 Borland International      }
  11. {         Used with permission                             }
  12. {                                                          }
  13. {----------------------------------------------------------}
  14. {  Borland - Interface                                     }
  15. {  Matthias Withopf / c't - limited Port to OS/2           }
  16. {  Rohit Gupta  -  Completed DOS compatability             }
  17. {  Rick Widmer - Added comments                            }
  18. {**********************************************************}
  19.  
  20.  
  21.  
  22. {****************************************}
  23. {                                        }
  24. {      ***    ****   *****     *         }
  25. {      *  *   *        *      * *        }
  26. {      ***    ***      *      ***        }
  27. {      *  *   *        *     *   *       }
  28. {      ***    ****     *     *   *       }
  29. {                                        }
  30. { Please report problems (and successes) }
  31. { on BPASCAL section 17. Prefix all      }
  32. { messages with BP4OS2.                  }
  33. {                                        }
  34. { Internet: 72162.470@compuserve.com     }
  35. {                                        }
  36. { NOTE:  Flags, Registers, MSDOS, INTR   }
  37. {        GetIntVec and SetIntVec are     }
  38. {        in Compatab.Pas                 }
  39. {                                        }
  40. {        The functions of Keep and       }
  41. {        SwapVectors are not needed      }
  42. {        with OS/2, they are not         }
  43. {        supported.                      }
  44. {                                        }
  45. {        GetCBreak and SetCBreak have    }
  46. {        not been needed yet, and are    }
  47. {        not ported.                     }
  48. {                                        }
  49. {****************************************}
  50.  
  51. interface
  52.  
  53. uses
  54.   Os2Def, BseDos, BseSub;
  55.  
  56. const
  57.  
  58. { Flags bit masks }
  59.  
  60.   FCarry     = $0001;
  61.   FParity    = $0004;
  62.   FAuxiliary = $0010;
  63.   FZero      = $0040;
  64.   FSign      = $0080;
  65.   FOverflow  = $0800;
  66.  
  67. { File mode magic numbers }
  68.  
  69.   fmClosed = $D7B0;
  70.   fmInput  = $D7B1;
  71.   fmOutput = $D7B2;
  72.   fmInOut  = $D7B3;
  73.  
  74. { File attribute constants }
  75.  
  76.   ReadOnly  = $01;
  77.   Hidden    = $02;
  78.   SysFile   = $04;
  79.   VolumeId  = $08;
  80.   Directory = $10;
  81.   Archive   = $20;
  82.   AnyFile   = $37;
  83.  
  84. type
  85.  
  86. { String types }
  87.  
  88.   ComStr  = string[127];        { Command line string }
  89.   PathStr = string[79];         { File pathname string }
  90.   DirStr  = string[67];         { Drive and directory string }
  91.   NameStr = string[8];          { File name string }
  92.   ExtStr  = string[4];          { File extension string }
  93.  
  94. { Registers record used by Intr and MsDos }
  95.  
  96.   Registers = record
  97.                 case Integer of
  98.                   0: (AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags: Word);
  99.                   1: (AL,AH,BL,BH,CL,CH,DL,DH: Byte);
  100.               end;
  101.  
  102. { Typed-file and untyped-file record }
  103.  
  104.   FileRec = record
  105.               Handle  : Word;
  106.               Mode    : Word;
  107.               RecSize : Word;
  108.               Private : array[1..26] of Byte;
  109.               UserData: array[1..16] of Byte;
  110.               Name    : array[0..79] of Char;
  111.             end;
  112.  
  113. { Textfile record }
  114.  
  115.   TextBuf = array[0..127] of Char;
  116.   TextRec = record
  117.               Handle   : Word;
  118.               Mode     : Word;
  119.               BufSize  : Word;
  120.               Private  : Word;
  121.               BufPos   : Word;
  122.               Bufend   : Word;
  123.               BufPtr   : ^TextBuf;
  124.               OpenFunc : Pointer;
  125.               InOutFunc: Pointer;
  126.               FlushFunc: Pointer;
  127.               CloseFunc: Pointer;
  128.               UserData : array[1..16] of Byte;
  129.               Name     : array[0..79] of Char;
  130.               Buffer   : TextBuf;
  131.             end;
  132.  
  133. { Search record used by FindFirst and FindNext }
  134.  
  135.   SearchRec = record
  136.                 Fill: array[1..21] of Byte;
  137.                 Attr: Byte;
  138.                 Time: Longint;
  139.                 Size: Longint;
  140.                 Name: string[12];
  141.               end;
  142.  
  143. { Date and time record used by PackTime and UnpackTime }
  144.  
  145.   DateTime = record
  146.                Year,Month,Day,Hour,Min,Sec: Word;
  147.              end;
  148. const
  149.  
  150.   ExecFlags     : Word = 0;   { EXEC_SYNC }
  151.  
  152. var
  153.  
  154. { Error status variable }
  155.  
  156.   DosError: Integer;
  157.  
  158. { OS/2 Global Information Segment pointer }
  159.  
  160.   GlobalInfoSeg: pGInfoSeg;
  161.  
  162. { OS/2 Local Information Segment pointer }
  163.  
  164.   LocalInfoSeg : pLInfoSeg;
  165.  
  166.  
  167. { DosVersion returns the DOS version number. The low byte of    }
  168. { the result is the major version number, and the high byte is  }
  169. { the minor version number. For example, DOS 3.20 returns 3 in  }
  170. { the low byte, and 20 in the high byte.                        }
  171.  
  172. function  DosVersion: Word;
  173.  
  174. { Intr executes a specified software interrupt with a specified }
  175. { Registers package.                                            }
  176.  
  177. procedure Intr(IntNo: Byte; var Regs: Registers);
  178.  
  179. { MsDos invokes the DOS function call handler with a specified  }
  180. { Registers package.                                            }
  181.  
  182. procedure MsDos(var Regs: Registers);
  183.  
  184. { GetDate returns the current date set in the operating system. }
  185. { Ranges of the values returned are: Year 1980-2099, Month      }
  186. { 1-12, Day 1-31 and DayOfWeek 0-6 (0 corresponds to Sunday).   }
  187.  
  188. procedure GetDate(var Year,Month,Day,DayofWeek: Word);
  189.  
  190. { SetDate sets the current date in the operating system. Valid  }
  191. { parameter ranges are: Year 1980-2099, Month 1-12 and Day      }
  192. { 1-31. If the date is not valid, the function call is ignored. }
  193.  
  194. procedure SetDate(Year,Month,Day: Word);
  195.  
  196. { GetTime returns the current time set in the operating system. }
  197. { Ranges of the values returned are: Hour 0-23, Minute 0-59,    }
  198. { Second 0-59 and Sec100 (hundredths of seconds) 0-99.          }
  199.  
  200. procedure GetTime(var Hour,Minute,Second,Sec100: Word);
  201.  
  202. { SetTime sets the time in the operating system. Valid          }
  203. { parameter ranges are: Hour 0-23, Minute 0-59, Second 0-59 and }
  204. { Sec100 (hundredths of seconds) 0-99. If the time is not       }
  205. { valid, the function call is ignored.                          }
  206.  
  207. procedure SetTime(Hour,Minute,Second,Sec100: Word);
  208.  
  209. { GetCBreak returns the state of Ctrl-Break checking in DOS.    }
  210. { When off (False), DOS only checks for Ctrl-Break during I/O   }
  211. { to console, printer, or communication devices. When on        }
  212. { (True), checks are made at every system call.                 }
  213.  
  214. procedure GetCBreak(var Break: Boolean);
  215.  
  216. { SetCBreak sets the state of Ctrl-Break checking in DOS.       }
  217.  
  218. procedure SetCBreak(Break: Boolean);
  219.  
  220. { GetVerify returns the state of the verify flag in DOS. When   }
  221. { off (False), disk writes are not verified. When on (True),    }
  222. { all disk writes are verified to insure proper writing.        }
  223.  
  224. procedure GetVerify(var Verify: Boolean);
  225.  
  226. { SetVerify sets the state of the verify flag in DOS.           }
  227.  
  228. procedure SetVerify(Verify: Boolean);
  229.  
  230. { DiskFree returns the number of free bytes on the specified    }
  231. { drive number (0=Default,1=A,2=B,..). DiskFree returns -1 if   }
  232. { the drive number is invalid.                                  }
  233.  
  234. function  DiskFree(Drive: Byte) : Longint;
  235.  
  236. { DiskSize returns the size in bytes of the specified drive     }
  237. { number (0=Default,1=A,2=B,..). DiskSize returns -1 if the     }
  238. { drive number is invalid.                                      }
  239.  
  240. function  DiskSize(Drive: Byte) : Longint;
  241.  
  242. { GetFAttr returns the attributes of a file. F must be a file   }
  243. { variable (typed, untyped or textfile) which has been assigned }
  244. { a name. The attributes are examined by ANDing with the        }
  245. { attribute masks defined as constants above. Errors are        }
  246. { reported in DosError.                                         }
  247.  
  248. procedure GetFAttr(var F; var Attr: Word);
  249.  
  250. { SetFAttr sets the attributes of a file. F must be a file      }
  251. { variable (typed, untyped or textfile) which has been assigned }
  252. { a name. The attribute value is formed by adding (or ORing)    }
  253. { the appropriate attribute masks defined as constants above.   }
  254. { Errors are reported in DosError.                              }
  255.  
  256. procedure SetFAttr(var F; Attr: Word);
  257.  
  258. { GetFTime returns the date and time a file was last written.   }
  259. { F must be a file variable (typed, untyped or textfile) which  }
  260. { has been assigned and opened. The Time parameter may be       }
  261. { unpacked throgh a call to UnpackTime. Errors are reported in  }
  262. { DosError.                                                     }
  263.  
  264. procedure GetFTime(var F; var Time: Longint);
  265.  
  266. { SetFTime sets the date and time a file was last written.      }
  267. { F must be a file variable (typed, untyped or textfile) which  }
  268. { has been assigned and opened. The Time parameter may be       }
  269. { created through a call to PackTime. Errors are reported in    }
  270. { DosError.                                                     }
  271.  
  272. procedure SetFTime(var F; Time: Longint);
  273.  
  274. { FindFirst searches the specified (or current) directory for   }
  275. { the first entry that matches the specified filename and       }
  276. { attributes. The result is returned in the specified search    }
  277. { record. Errors (and no files found) are reported in DosError. }
  278.  
  279. procedure FindFirst(Path: PathStr; Attr: Word; var S: SearchRec);
  280.  
  281. { FindNext returs the next entry that matches the name and      }
  282. { attributes specified in a previous call to FindFirst. The     }
  283. { search record must be one passed to FindFirst. Errors (and no }
  284. { more files) are reported in DosError.                         }
  285.  
  286. procedure FindNext(var S: SearchRec);
  287.  
  288. { UnpackTime converts a 4-byte packed date/time returned by     }
  289. { FindFirst, FindNext or GetFTime into a DateTime record.       }
  290.  
  291. procedure UnpackTime(P: Longint; var T: DateTime);
  292.  
  293. { PackTime converts a DateTime record into a 4-byte packed      }
  294. { date/time used by SetFTime.                                   }
  295.  
  296. procedure PackTime(var T: DateTime; var P: LongInt);
  297.  
  298. { GetIntVec returns the address stored in the specified         }
  299. { interrupt vector.                                             }
  300.  
  301. procedure GetIntVec(IntNo: Byte; var Vector: Pointer);
  302.  
  303. { SetIntVec sets the address in the interrupt vector table for  }
  304. { the specified interrupt.                                      }
  305.  
  306. procedure SetIntVec(IntNo: Byte; Vector: Pointer);
  307.  
  308. { FSearch searches for the file given by Path in the list of    }
  309. { directories given by DirList. The directory paths in DirList  }
  310. { must be separated by semicolons. The search always starts     }
  311. { with the current directory of the current drive. The returned }
  312. { value is a concatenation of one of the directory paths and    }
  313. { the file name, or an empty string if the file could not be    }
  314. { located.                                                      }
  315.  
  316. function  FSearch(Path: PathStr; DirList: string): PathStr;
  317.  
  318. { FExpand expands the file name in Path into a fully qualified  }
  319. { file name. The resulting name consists of a drive letter, a   }
  320. { colon, a root relative directory path, and a file name.       }
  321. { Embedded '.' and '..' directory references are removed.       }
  322.  
  323. function  FExpand(Path: PathStr): PathStr;
  324.  
  325. { FSplit splits the file name specified by Path into its three  }
  326. { components. Dir is set to the drive and directory path with   }
  327. { any leading and trailing backslashes, Name is set to the file }
  328. { name, and Ext is set to the extension with a preceding dot.   }
  329. { Each of the component strings may possibly be empty, if Path  }
  330. { contains no such component.                                   }
  331.  
  332. procedure FSplit(Path: PathStr; var Dir: DirStr;
  333.               var Name: NameStr; var Ext: ExtStr);
  334.  
  335. { EnvCount returns the number of strings contained in the DOS   }
  336. { environment.                                                  }
  337.  
  338. function  EnvCount : Integer;
  339.  
  340. { EnvStr returns a specified environment string. The returned   }
  341. { string is of the form "VAR=VALUE". The index of the first     }
  342. { string is one. If Index is less than one or greater than      }
  343. { EnvCount, EnvStr returns an empty string.                     }
  344.  
  345. function  EnvStr(Index: Integer): string;
  346.  
  347. { GetEnv returns the value of a specified environment variable. }
  348. { The variable name can be in upper or lower case, but it must  }
  349. { not include the '=' character. If the specified environment   }
  350. { variable does not exist, GetEnv returns an empty string.      }
  351.  
  352. function  GetEnv(Envvar: string): string;
  353.  
  354. { SwapVectors swaps the contents of the SaveIntXX pointers in   }
  355. { the System unit with the current contents of the interrupt    }
  356. { vectors. SwapVectors is typically called just before and just }
  357. { after a call to Exec. This insures that the Exec'd process    }
  358. { does not use any interrupt handlers installed by the current  }
  359. { process, and vice versa.                                      }
  360.  
  361. procedure SwapVectors;
  362.  
  363. {**                                                           **}
  364. {** SwapVectors is no longer needed.  Exec starts a separate  **}
  365. {** session that does not depend on the machine state, or use **}
  366. {** any memory of this session.                               **}
  367. {**                                                           **}
  368.  
  369. { Keep (or Terminate Stay Resident) terminates the program and  }
  370. { makes it stay in memory. The entire program stays in memory,  }
  371. { including data segment, stack segment, and heap. The ExitCode }
  372. { corresponds to the one passed to the Halt standard procedure. }
  373.  
  374. procedure Keep(ExitCode: Word);
  375.  
  376. {**                                                           **}
  377. {**    OS/2 makes the whole idea of TSR programs obsolete.    **}
  378. {**  this procedure is no longer supported.                   **}
  379. {**                                                           **}
  380.  
  381. { Exec executes another program. The program is specified by    }
  382. { the Path parameter, and the command line is specified by the  }
  383. { CmdLine parameter. To execute a DOS internal command, run     }
  384. { COMMAND.COM, e.g. "Exec('\COMMAND.COM','/C DIR *.PAS');".     }
  385. { Note the /C in front of the command. Errors are reported in   }
  386. { DosError. When compiling a program that uses Exec, be sure    }
  387. { to specify a maximum heap size as there will otherwise not be }
  388. { enough memory.                                                }
  389.  
  390. procedure Exec(Path: PathStr; ComLine: ComStr);
  391.  
  392. { DosExitCode returns the exit code of a sub-process. The low   }
  393. { byte is the code sent by the terminating process. The high    }
  394. { byte is zero for normal termination, 1 if terminated by       }
  395. { Ctrl-C, 2 if terminated due to a device error, or 3 if        }
  396. { terminated by the Keep procedure (function call 31 hex).      }
  397.  
  398. function  DosExitCode: Word;
  399.  
  400. { Extra routines for OS/2                                       }
  401.  
  402. procedure PlaySound(Frequency, Duration: Word);
  403.  
  404. implementation
  405.  
  406. const
  407.   Video_IO  = $10;
  408.   Keybd_IO  = $16;
  409.   Dos_Int   = $21;
  410.  
  411.  
  412. procedure USI(Msg: String; IntNo: Byte);
  413.   begin
  414.     Writeln(Msg, ': ', IntNo);
  415.     Halt;
  416.   end;
  417.  
  418.  
  419. procedure SetMode(Mode: Byte); near;
  420.   var
  421.     CrtVioMode : tVioModeInfo;
  422.   begin
  423.     CrtVioMode.cb := SizeOf(tVioModeInfo);
  424.     VioGetMode(CrtVioMode, 0);
  425.     case Mode of
  426.       $00:
  427.         begin
  428.           CrtVioMode.fbType := 5;
  429.           CrtVioMode.color  := 4;
  430.           CrtVioMode.col    := 40;
  431.           CrtVioMode.row    := 25;
  432.           CrtVioMode.hres   := 360;
  433.           CrtVioMode.vres   := 400;
  434.         end;
  435.       $01:
  436.         begin
  437.           CrtVioMode.fbType := 1;
  438.           CrtVioMode.color  := 4;
  439.           CrtVioMode.col    := 40;
  440.           CrtVioMode.row    := 25;
  441.           CrtVioMode.hres   := 360;
  442.           CrtVioMode.vres   := 400;
  443.         end;
  444.       $02:
  445.         begin
  446.           CrtVioMode.fbType := 5;
  447.           CrtVioMode.color  := 4;
  448.           CrtVioMode.col    := 80;
  449.           CrtVioMode.row    := 25;
  450.           CrtVioMode.hres   := 720;
  451.           CrtVioMode.vres   := 400;
  452.         end;
  453.       $03:
  454.         begin
  455.           CrtVioMode.fbType := 1;
  456.           CrtVioMode.color  := 4;
  457.           CrtVioMode.col    := 80;
  458.           CrtVioMode.row    := 25;
  459.           CrtVioMode.hres   := 720;
  460.           CrtVioMode.vres   := 400;
  461.         end;
  462.       $04:
  463.         begin
  464.           CrtVioMode.fbType := 3;
  465.           CrtVioMode.color  := 2;
  466.           CrtVioMode.col    := 40;
  467.           CrtVioMode.row    := 25;
  468.           CrtVioMode.hres   := 320;
  469.           CrtVioMode.vres   := 200;
  470.         end;
  471.       $05:
  472.         begin
  473.           CrtVioMode.fbType := 7;
  474.           CrtVioMode.color  := 2;
  475.           CrtVioMode.col    := 40;
  476.           CrtVioMode.row    := 25;
  477.           CrtVioMode.hres   := 320;
  478.           CrtVioMode.vres   := 200;
  479.         end;
  480.       $06:
  481.         begin
  482.           CrtVioMode.fbType := 3;
  483.           CrtVioMode.color  := 1;
  484.           CrtVioMode.col    := 80;
  485.           CrtVioMode.row    := 25;
  486.           CrtVioMode.hres   := 640;
  487.           CrtVioMode.vres   := 200;
  488.         end;
  489.       $07:
  490.         begin
  491.           CrtVioMode.fbType := 0;
  492.           CrtVioMode.color  := 0;
  493.           CrtVioMode.col    := 80;
  494.           CrtVioMode.row    := 25;
  495.           CrtVioMode.hres   := 720;
  496.           CrtVioMode.vres   := 400;
  497.         end;
  498.       $0D:
  499.         begin
  500.           CrtVioMode.fbType := 3;
  501.           CrtVioMode.color  := 4;
  502.           CrtVioMode.col    := 40;
  503.           CrtVioMode.row    := 25;
  504.           CrtVioMode.hres   := 320;
  505.           CrtVioMode.vres   := 200;
  506.         end;
  507.       $0E:
  508.         begin
  509.           CrtVioMode.fbType := 3;
  510.           CrtVioMode.color  := 4;
  511.           CrtVioMode.col    := 80;
  512.           CrtVioMode.row    := 25;
  513.           CrtVioMode.hres   := 640;
  514.           CrtVioMode.vres   := 200;
  515.         end;
  516.       $0F:
  517.         begin
  518.           CrtVioMode.fbType := 2;
  519.           CrtVioMode.color  := 0;
  520.           CrtVioMode.col    := 80;
  521.           CrtVioMode.row    := 25;
  522.           CrtVioMode.hres   := 640;
  523.           CrtVioMode.vres   := 350;
  524.         end;
  525.       $10:
  526.         begin
  527.           CrtVioMode.fbType := 3;
  528.           CrtVioMode.color  := 4;
  529.           CrtVioMode.col    := 80;
  530.           CrtVioMode.row    := 25;
  531.           CrtVioMode.hres   := 640;
  532.           CrtVioMode.vres   := 350;
  533.         end;
  534.       $11:
  535.         begin
  536.           CrtVioMode.fbType := 3;
  537.           CrtVioMode.color  := 1;
  538.           CrtVioMode.col    := 80;
  539.           CrtVioMode.row    := 30;
  540.           CrtVioMode.hres   := 640;
  541.           CrtVioMode.vres   := 480;
  542.         end;
  543.       $12:
  544.         begin
  545.           CrtVioMode.fbType := 3;
  546.           CrtVioMode.color  := 4;
  547.           CrtVioMode.col    := 80;
  548.           CrtVioMode.row    := 30;
  549.           CrtVioMode.hres   := 640;
  550.           CrtVioMode.vres   := 480;
  551.         end;
  552.       $13:
  553.         begin
  554.           CrtVioMode.fbType := 3;
  555.           CrtVioMode.color  := 8;
  556.           CrtVioMode.col    := 40;
  557.           CrtVioMode.row    := 25;
  558.           CrtVioMode.hres   := 320;
  559.           CrtVioMode.vres   := 200;
  560.         end;
  561.     end;
  562.     VioSetMode(CrtVioMode, 0)
  563.   end;
  564.  
  565.  
  566. function GetMode: Byte; near;
  567.   var
  568.     CrtVioMode : tVioModeInfo;
  569.     Mode: Byte;
  570.   begin
  571.     CrtVioMode.cb := SizeOf(tVioModeInfo);
  572.     VioGetMode(CrtVioMode, 0);
  573.     if (CrtVioMode.fbType and 2) = 0 then  { Text Mode }
  574.       begin
  575.         if CrtVioMode.fbType = 0 then
  576.           Mode := 7
  577.         else
  578.           begin
  579.             if CrtVioMode.col = 40 then
  580.               Mode := 1
  581.             else if CrtVioMode.col = 80 then
  582.               Mode := $3
  583.             else
  584.               Mode := $FF;
  585.             if CrtVioMode.fbType = 5 then
  586.               Dec(Mode);
  587.           end;
  588.       end
  589.     else                                { Graphic mode }
  590.       begin
  591.         case CrtVioMode.color of
  592.           0:
  593.             Mode := $0F;
  594.           1:
  595.             begin
  596.               if CrtVioMode.row = 30 then
  597.                 Mode := $11
  598.               else
  599.                 Mode := $06;
  600.             end;
  601.           2:
  602.             begin
  603.               if CrtVioMode.fbType = 7 then
  604.                 Mode := $05
  605.               else
  606.                 Mode := $04;
  607.             end;
  608.           4:
  609.             begin
  610.               if CrtVioMode.col = 40 then
  611.                 Mode := $0D
  612.               else
  613.                 case CrtVioMode.vres of
  614.                   200:
  615.                     Mode := $0E;
  616.                   350:
  617.                     Mode := $10;
  618.                   480:
  619.                     Mode := $12;
  620.                 end;
  621.             end;
  622.           8:
  623.             Mode := $13
  624.         else
  625.           Mode := $FF;
  626.         end;
  627.       end;
  628.     GetMode := Mode;
  629.   end;
  630.  
  631. procedure Int10(var Regs: Registers);
  632.   type
  633.     tCell = record
  634.       c, a: Byte;
  635.     end;
  636.  
  637.   var
  638.     Row, Col,
  639.     Len       : Word;
  640.     Cell      : tCell;
  641.     CursorInfo: tVioCursorInfo;
  642.  
  643.   begin
  644.     case Regs.AH of
  645.       $00 :
  646.         SetMode(Regs.AL);
  647.       $01 :                             { Set cursor type }
  648.         begin
  649.           CursorInfo.yStart := Regs.CH;
  650.           CursorInfo.cend   := Regs.CL;
  651.           CursorInfo.cx     := 0;
  652.           CursorInfo.attr   := 0;
  653.           VioSetCurType(CursorInfo, 0);
  654.         end;
  655.       $02 :                             { Set cursor position }
  656.         VioSetCurPos(Regs.DH, Regs.DL, 0);
  657.       $03 :                             { Read cursor position }
  658.         begin
  659.           VioGetCurType(CursorInfo, 0);
  660.           Regs.CH := CursorInfo.yStart;
  661.           Regs.CL := CursorInfo.cend;
  662.           VioGetCurPos(Row, Col, 0);
  663.           Regs.DH := Lo(Row);
  664.           Regs.DL := Lo(Col);
  665.         end;
  666.       $06 :                             { Scroll window up }
  667.         begin
  668.           Cell.a := Regs.BH;
  669.           Cell.c := $20;
  670.           if Regs.AL = 0 then
  671.             Regs.AX := $FFFF
  672.           else
  673.             Regs.AH := 0;
  674.           VioScrollUp(Regs.CH, Regs.CL, Regs.DH, Regs.DL, Regs.AX, Cell, 0);
  675.         end;
  676.       $07 :                             { Scroll window down }
  677.         begin
  678.           Cell.a := Regs.BH;
  679.           Cell.c := $20;
  680.           if Regs.AL = 0 then
  681.             Regs.AX := $FFFF
  682.           else
  683.             Regs.AH := 0;
  684.           VioScrollDn(Regs.CH, Regs.CL, Regs.DH, Regs.DL, Regs.AX, Cell, 0);
  685.         end;
  686.       $08 :                             { Read character and attrib }
  687.         begin
  688.           VioGetCurPos(Row, Col, 0);
  689.           Len := SizeOf(Cell);
  690.           VioReadCellStr(Cell, Len, Row, Col, 0);
  691.           Regs.AH := Cell.a;
  692.           Regs.AL := Cell.c;
  693.         end;
  694.       $09 :                             { Write character and attrib }
  695.         begin
  696.           VioGetCurPos(Row, Col, 0);
  697.           Cell.c := Regs.AL;
  698.           Cell.a := Regs.BL;
  699.           VioWrtNCell(Cell, Regs.CX, Row, Col, 0);
  700.         end;
  701.       $0A :                             { Write character only }
  702.         begin
  703.           VioGetCurPos(Row, Col, 0);
  704.           VioWrtNChar(Regs.AL, Regs.CX, Row, Col, 0);
  705.         end;
  706.       $0E :
  707.         begin
  708.           Cell.c := Regs.AL;
  709.           Cell.a := $0;
  710.           VioWrtTTY(Cell, 1, 0);
  711.         end;
  712.       $0F :
  713.         begin
  714.           Regs.AL := GetMode;
  715.         end;
  716.     else
  717.       USI('Unsupported Video Function', Regs.AH);
  718.     end;
  719.   end;
  720.  
  721.  
  722. procedure Int16(var Regs: Registers);
  723.   var
  724.     KeyInfo: tKbdKeyInfo;
  725.     KbdInfo: tKbdInfo;
  726.  
  727.   begin
  728.     case Regs.AH of
  729.       $00, $10 :
  730.         begin
  731.           KbdCharIn(KeyInfo, io_Wait, 0);
  732.           Regs.AL := Ord(KeyInfo.chChar);
  733.           Regs.AH := Ord(KeyInfo.chScan);
  734.         end;
  735.       $01, $11 :                      { Check for keystroke. }
  736.         begin
  737.           KbdPeek(KeyInfo, 0);
  738.           if (KeyInfo.fbStatus and $40) <> 0 then
  739.             begin
  740.               Regs.Flags := Regs.Flags and Not(FZero);
  741.               Regs.AL    := Ord(KeyInfo.chChar);
  742.               Regs.AH    := Ord(KeyInfo.chScan);
  743.             end
  744.           else
  745.             Regs.Flags := Regs.Flags or FZero;
  746.         end;
  747.       $02, $12 :                      { Read flags }
  748.         begin
  749.           KbdInfo.cb := 10;
  750.           KbdGetStatus(KbdInfo, 0);
  751.           if Regs.AH = $02 then
  752.             Regs.AH := 0
  753.           else
  754.             Regs.AH := Hi(KbdInfo.fsState);
  755.           Regs.AL := Lo(KbdInfo.fsState);
  756.         end
  757.     else
  758.       USI('Unsupported Keyboard Function', Regs.AH);
  759.     end;
  760.   end;
  761.  
  762.  
  763. procedure MsDos(var Regs: Registers);
  764.   var
  765.     Row, Col,
  766.     DrvNum   : Word;
  767.     LogDrvMap: Longint;
  768.     KeyInfo  : tKbdKeyInfo;
  769.     i        : Integer;
  770.   begin
  771.     case Regs.AH of
  772.       $00 :
  773.         DosExit(0, 0);
  774.       $01 :
  775.         begin
  776.           KbdCharIn(KeyInfo, io_Wait, 0);
  777.           Regs.AL := Ord(KeyInfo.chChar);
  778.         end;
  779.       $02 :
  780.         begin
  781.           VioGetCurPos(Row, Col, 0);
  782.           VioWrtNChar(Regs.AL, 1, Row, Col, 0);
  783.         end;
  784.  
  785.       $0E :
  786.         begin
  787.           DosSelectDisk(Word(Regs.DL + 1));
  788.           DosQCurDisk(DrvNum, LogDrvMap);
  789.           Regs.AL := 0;
  790.           for i := 0 to 25 do
  791.             if (LogDrvMap and 1) = 1 then
  792.               begin
  793.                 Inc(Regs.AL);
  794.                 LogDrvMap := LogDrvMap shr 1;
  795.               end;
  796.         end;
  797.     end;
  798.  
  799.   end;
  800.  
  801.  
  802. procedure Intr(IntNo: Byte; var Regs: Registers);
  803.   begin
  804.     case IntNo of
  805.       Video_IO :
  806.         Int10(Regs);
  807.       Keybd_IO :
  808.         Int16(Regs);
  809.       Dos_Int :
  810.         MsDos(Regs)
  811.     else
  812.       USI('Unsupported Interrupt', IntNo);
  813.     end;
  814.   end;
  815.  
  816.  
  817. function DosVersion: Word;
  818.   begin
  819.     DosVersion := GlobalInfoSeg^.uchMajorVersion
  820.                   + (GlobalInfoSeg^.uchMinorVersion shl 8);
  821.   end;
  822.  
  823.  
  824. procedure GetDate(var Year,Month,Day,DayofWeek: Word);
  825.   begin
  826.     Year      := GlobalInfoSeg^.year;
  827.     Month     := GlobalInfoSeg^.month;
  828.     Day       := GlobalInfoSeg^.day;
  829.     DayofWeek := GlobalInfoSeg^.weekday;
  830.   end;
  831.  
  832.  
  833. procedure SetDate(Year, Month, Day: Word);
  834.   var
  835.     DT: tDateTime;
  836.   begin
  837.     DosError := DosGetDateTime(DT);
  838.     if DosError = 0 then
  839.       begin
  840.         DT.Year    := Year;
  841.         DT.Month   := Month;
  842.         DT.Day     := Day;
  843.         DosSetDateTime(DT);
  844.       end;
  845.   end;
  846.  
  847.  
  848. procedure GetTime(var Hour, Minute, Second, Sec100: Word);
  849.   begin
  850.     Hour   := GlobalInfoSeg^.hour;
  851.     Minute := GlobalInfoSeg^.minutes;
  852.     Second := GlobalInfoSeg^.seconds;
  853.     Sec100 := GlobalInfoSeg^.hundredths;
  854.   end;
  855.  
  856.  
  857. procedure SetTime(Hour, Minute, Second, Sec100: Word);
  858.   var
  859.     DT: tDateTime;
  860.   begin
  861.     DosError := DosGetDateTime(DT);
  862.     if DosError = 0 then
  863.       begin
  864.         DT.Hours      := Hour;
  865.         DT.Minutes    := Minute;
  866.         DT.Seconds    := Second;
  867.         DT.Hundredths := Sec100;
  868.         DosSetDateTime(DT);
  869.       end;
  870.   end;
  871.  
  872.  
  873. procedure GetCBreak(var Break: Boolean);
  874.   begin
  875.     Break := True;
  876.   end;
  877.  
  878.  
  879. procedure SetCBreak(Break: Boolean);
  880.   begin
  881.  
  882.   end;
  883.  
  884.  
  885. procedure GetVerify(var Verify: Boolean);
  886.   var
  887.     V: Word;
  888.   begin
  889.     DosError := DosQVerify(V);
  890.     if DosError = 0 then
  891.       Verify := Boolean(V)
  892.     else
  893.       Verify := False;
  894.   end;
  895.  
  896.  
  897. procedure SetVerify(Verify: Boolean);
  898.   begin
  899.     DosError := DosSetVerify(Word(Verify));
  900.   end;
  901.  
  902.  
  903. function DiskFree(Drive: Byte): Longint;
  904.   var
  905.     FI: tFSAllocate;
  906.   begin
  907.     DosError := DosQFSInfo(Drive, 1, FI, sizeof(FI));
  908.     if DosError = 0 then
  909.       DiskFree := FI.cUnitAvail * FI.cSectorUnit * FI.cbSector
  910.     else
  911.       DiskFree := -1;
  912.   end;
  913.  
  914.  
  915. function DiskSize(Drive: Byte): Longint;
  916.   var
  917.     FI: tFSAllocate;
  918.   begin
  919.     DosError := DosQFSInfo(Drive, 1, FI, sizeof(FI));
  920.     if DosError = 0 then
  921.       DiskSize := FI.cUnit * FI.cSectorUnit * FI.cbSector
  922.     else
  923.       DiskSize := -1;
  924.   end;
  925.  
  926.  
  927. procedure GetFAttr(var F; var Attr: Word);
  928.   var
  929.     A: Word;
  930.   begin
  931.     DosError := DosQFileMode(FileRec(F).Name, A, 0);
  932.     if DosError = 0 then
  933.       Attr := A
  934.     else
  935.       Attr := 0;
  936.   end;
  937.  
  938.  
  939. procedure SetFAttr(var F; Attr: Word);
  940.   begin
  941.     DosError := DosSetFileMode(FileRec(F).Name, Attr, 0);
  942.   end;
  943.  
  944.  
  945. procedure GetFTime(var F; var Time: Longint);
  946.   var
  947.     FI: tFileStatus;
  948.     T1: record
  949.           Time,Date: Word;
  950.         end absolute Time;
  951.   begin
  952.     DosError := DosQFileInfo(FileRec(F).Handle, 1, FI, SizeOf(FI));
  953.     if DosError = 0 then
  954.       begin
  955.         T1.Time := FI.fTimeLastWrite;
  956.         T1.Date := FI.fDateLastWrite;
  957.       end
  958.     else
  959.       begin
  960.         T1.Time := 0;
  961.         T1.Date := 0;
  962.       end;
  963.   end;
  964.  
  965.  
  966. procedure SetFTime(var F; Time: Longint);
  967.   var
  968.     FI: tFileStatus;
  969.     T1: record
  970.           Time,Date: Word;
  971.         end absolute Time;
  972.   begin
  973.     DosError := DosQFileInfo(FileRec(f).Handle, 1, FI, SizeOf(FI));
  974.     if DosError = 0 then
  975.       begin
  976.         FI.fTimeLastWrite := T1.Time;
  977.         FI.fDateLastWrite := T1.Date;
  978.         DosError := DosSetFileInfo(FileRec(f).Handle, 1, FI, SizeOf(FI));
  979.       end;
  980.   end;
  981.  
  982.  
  983. procedure FindFirst(Path: PathStr; Attr: Word; var S: SearchRec);
  984.   type
  985.     PWord = ^Word;
  986.   var
  987.     FF   : tFileFindBuf;
  988.     N    : string;
  989.     Count: Word;
  990.   begin
  991.     N := Path + #0;
  992.     Count := 1;
  993.     PWord(@S)^ := $FFFF; { HDIR_CREATE }
  994.     DosError := DosFindFirst(@N[1], PWord(@S)^, Attr, FF, SizeOf(FF), Count, 0);
  995.     if DosError = 0 then
  996.       begin
  997.         S.Attr := FF.AttrFile;
  998.         S.Time := (LongInt(FF.fDateLastWrite) shl 16) + FF.fTimeLastWrite;
  999.         S.Size := FF.cbFile;
  1000.         Move(FF.cchName, S.Name, SizeOf(S.Name))
  1001.       end;
  1002.   end;
  1003.  
  1004.  
  1005. procedure FindNext(var S: SearchRec);
  1006.   type
  1007.     PWord = ^Word;
  1008.   var
  1009.     FF   : tFileFindBuf;
  1010.     Count: Word;
  1011.   begin
  1012.     Count := 1;
  1013.     DosError := DosFindNext(PWord(@S)^, FF, SizeOf(FF), Count);
  1014.     if DosError = 0 then
  1015.       begin
  1016.         S.Attr := FF.AttrFile;
  1017.         S.Time := (LongInt(FF.fDateLastWrite) shl 16) + FF.fTimeLastWrite;
  1018.         S.Size := FF.cbFile;
  1019.         Move(FF.cchName, S.Name, SizeOf(S.Name))
  1020.       end
  1021.     else
  1022.       DosFindClose(PWord(@S)^);
  1023.   end;
  1024.  
  1025.  
  1026. procedure UnpackTime(P: Longint; var T: DateTime);
  1027.   var
  1028.     P1: record
  1029.           Time,Date: Word;
  1030.         end absolute P;
  1031.   begin
  1032.     T.Year  := P1.Date shr 9 + 1980;
  1033.     T.Month := (P1.Date shr 5) and 15;
  1034.     T.Day   := P1.Date and 31;
  1035.     T.Hour  := P1.Time shr 11;
  1036.     T.Min   := (P1.Time shr 5) and 63;
  1037.     T.Sec   := (P1.Time and 31) shl 1;
  1038.   end;
  1039.  
  1040.  
  1041. procedure PackTime(var T: DateTime; var P: Longint);
  1042.   var
  1043.     P1: record
  1044.           Time,Date: Word;
  1045.         end absolute P;
  1046.   begin
  1047.     P1.Date := (T.Year - 1980) shl 9 + T.Month shl 5 + T.Day;
  1048.     P1.Time := T.Hour shl 11 + T.Min shl 5 + T.Sec shr 1;
  1049.   end;
  1050.  
  1051.  
  1052. procedure GetIntVec(IntNo: Byte; var Vector: Pointer);
  1053.   var
  1054.     P: PFn;
  1055.   begin
  1056.     Vector := nil;
  1057.     if DosSetVec(IntNo, nil, P) = 0 then
  1058.       begin
  1059.         Vector := Pointer(P);
  1060.         DosSetVec(IntNo, P, P);
  1061.       end;
  1062.   end;
  1063.  
  1064.  
  1065. procedure SetIntVec(IntNo: Byte; Vector: Pointer);
  1066.   var
  1067.     P: pFn;
  1068.   begin
  1069.     DosSetVec(IntNo, pFn(Vector), P);
  1070.   end;
  1071.  
  1072.  
  1073. function FSearch(Path: PathStr; DirList: string): PathStr;
  1074.   var
  1075.     Name   : string;
  1076.     Attrib : Word;
  1077.     p      : Byte;
  1078.   begin
  1079.     FSearch := '';
  1080.     Name := Path;
  1081.     repeat
  1082.       Name := Name + #0;
  1083.       DosError := DosQFileMode(@Name[1], Attrib, 0);
  1084.       if (DosError = 0) and ((Attrib and $18) = 0) then
  1085.         begin
  1086.           FSearch := Copy(Name, 1, Length(Name) - 1);
  1087.           Break;
  1088.         end
  1089.       else
  1090.         begin
  1091.           if DirList = '' then Break;
  1092.           p := Pos(';', DirList);
  1093.           if p <> 0 then
  1094.             begin
  1095.               Name := Copy(DirList, 1, p - 1) + '\' + Path;
  1096.               DirList := Copy(DirList, p + 1, 255);
  1097.             end
  1098.           else
  1099.             begin
  1100.               Name := DirList + '\' + Path;
  1101.               DirList := '';
  1102.             end;
  1103.         end;
  1104.     until False;
  1105.   end;
  1106.  
  1107.  
  1108. function FExpand(Path: PathStr): PathStr;
  1109.   var
  1110.     s: string;
  1111.   begin
  1112.     GetDir(0, s);
  1113.     if s <> '' then
  1114.       if s[Length(s) - 1] <> '\' then
  1115.         s := s + '\';
  1116.     FExpand := s + Path;
  1117.   end;
  1118.  
  1119.  
  1120. procedure FSplit(Path: PathStr; var Dir: DirStr;
  1121.                  var Name: NameStr; var Ext: ExtStr);
  1122.   var
  1123.     l: Integer;
  1124.   begin
  1125.     l := Length(Path);
  1126.     While Not(Path[l] in ['\',':']) and (l > 0) do Dec(l);
  1127.     Dir := Copy(Path, 1, l);
  1128.     Path := Copy(Path, l + 1, 255);
  1129.     l := Pos('.', Path);
  1130.     if l <> 0 then
  1131.       begin
  1132.         Name := Copy(Path, 1, l - 1);
  1133.         Ext  := Copy(Path, l, 4);
  1134.       end
  1135.     else
  1136.       begin
  1137.         Name := Path;
  1138.         Ext  := '';
  1139.       end;
  1140.   end;
  1141.  
  1142.  
  1143. { Support Routine for EnvCount/EnvStr }
  1144. {
  1145. procedure EnvStrCnt; near; assembler;
  1146.   asm
  1147.     MOV   ES,EnvironmentSeg
  1148.     XOR   DI,DI
  1149.     CLD
  1150. @@1:
  1151.     XOR   AL,AL
  1152.     CMP   AL,ES:[DI]
  1153.     JE    @@2
  1154.     DEC   DX
  1155.     JE    @@2
  1156.     MOV   CX,-1
  1157.     REPNE SCASB
  1158.     JMP   @@1
  1159. @@2:
  1160.   end;
  1161. }
  1162.  
  1163. function EnvCount: Integer;
  1164.   const
  1165.     i: Integer = 0;
  1166.   var
  1167.     p: pChar;
  1168.   begin
  1169.     p := Ptr(EnvironmentSeg, 0);
  1170.     while p^ <> #0 do
  1171.       begin
  1172.         while p^ <> #0 do
  1173.           Inc(p);
  1174.         Inc(p);
  1175.         Inc(i);
  1176.       end;
  1177.     EnvCount := i;
  1178.   end;
  1179. {
  1180. function EnvCount: Integer; assembler;
  1181.   asm
  1182.     XOR   DX,DX
  1183.     CALL  EnvStrCnt
  1184.     XCHG  AX,DX
  1185.     NEG   AX
  1186.   end;
  1187. }
  1188.  
  1189. function EnvStr(Index: Integer): string;
  1190.   var
  1191.     p: pChar;
  1192.     s: string;
  1193.   begin
  1194.     p := Ptr(EnvironmentSeg, 0);
  1195.     while p^ <> #0 do
  1196.       begin
  1197.         Dec(Index);
  1198.         if Index <= 0 then
  1199.           Break;
  1200.         while p^ <> #0 do
  1201.           Inc(p);
  1202.         Inc(p);
  1203.       end;
  1204.     s := '';
  1205.     if Index = 0 then
  1206.       while p^ <> #0 do
  1207.         begin
  1208.           s := s + p^;
  1209.           Inc(p);
  1210.         end;
  1211.     EnvStr := s;
  1212.   end;
  1213.  
  1214. {
  1215. function EnvStr(Index: Integer): string; assembler;
  1216.   asm
  1217.     PUSH  DS
  1218.     MOV   DX,Index
  1219.     CALL  EnvStrCnt
  1220.     MOV   SI,DI
  1221.     PUSH  ES
  1222.     POP   DS
  1223.     XOR   AL,AL
  1224.     MOV   CX,256
  1225.     REPNE SCASB
  1226.     NOT   CL
  1227.     LES   DI,@Result
  1228.     MOV   AL,CL
  1229.     STOSB
  1230.     REP   MOVSB
  1231.     POP   DS
  1232.   end;
  1233. }
  1234.  
  1235. function GetEnv(EnvVar: string): string;
  1236.   var
  1237.     Cnt    : Integer;
  1238.     p      : pChar;
  1239.     s      : string;
  1240.     Srching: Boolean;
  1241.   begin
  1242.     for Cnt := Length(EnvVar) downto 1 do
  1243.       EnvVar[Cnt] := UpCase(EnvVar[Cnt]);
  1244.     p := Ptr(EnvironmentSeg, 0);
  1245.     while p^ <> #0 do
  1246.       begin
  1247.         s := '';
  1248.         Srching := True;
  1249.         while p^ <> #0 do
  1250.           begin
  1251.             if Srching and (p^ = '=') and (s = EnvVar) then
  1252.               begin
  1253.                 Srching := False;
  1254.                 s := '';
  1255.                 Inc(p);
  1256.                 Continue;
  1257.               end;
  1258.             s := s + p^;
  1259.             Inc(p);
  1260.           end;
  1261.         if Srching = False then
  1262.           begin
  1263.             GetEnv := s;
  1264.             Exit;
  1265.           end;
  1266.         Inc(p);
  1267.       end;
  1268.     GetEnv := '';
  1269.   end;
  1270.  
  1271.  
  1272. procedure SwapVectors;
  1273.   begin
  1274.  
  1275.   end;
  1276.  
  1277.  
  1278. procedure Keep(ExitCode: Word);
  1279.   begin
  1280.  
  1281.   end;
  1282.  
  1283.  
  1284. var
  1285.   ExecResult: tResultCodes;
  1286.  
  1287.  
  1288. procedure Exec(Path: PathStr; ComLine: ComStr);
  1289.   var
  1290.     b: array[0..255] of Char;
  1291.     c: string;
  1292.   begin
  1293.     if (length(comline) > 0) and (comline[1] <> ' ') then
  1294.        c := path + #0' ' + comline + #0#0
  1295.     else
  1296.       c := path + #0 + comline + #0#0;
  1297.     DosError := DosExecPgm(b, 256, ExecFlags, @c[1], Ptr(EnvironmentSeg, 0),
  1298.                            ExecResult, @c[1]);
  1299.   end;
  1300.  
  1301.  
  1302. function DosExitCode: Word;
  1303.   begin
  1304.     DosExitCode := ExecResult.CodeResult;
  1305.   end;
  1306.  
  1307.  
  1308. procedure PlaySound(Frequency, Duration: Word);
  1309.   begin
  1310.     DosBeep(Frequency, Duration);
  1311.   end;
  1312.  
  1313.  
  1314. procedure DosInit;
  1315.   var
  1316.     GlobalSel, LocalSel: Sel;
  1317.   begin
  1318.     if DosGetInfoSeg(GlobalSel, LocalSel) = 0 then
  1319.       begin
  1320.         GlobalInfoSeg := Ptr(GlobalSel, 0);
  1321.         LocalInfoSeg  := Ptr(LocalSel, 0);
  1322.       end
  1323.     else
  1324.       begin
  1325.         GlobalInfoSeg := nil;
  1326.         LocalInfoSeg  := nil;
  1327.       end;
  1328.   end;
  1329.  
  1330.  
  1331. begin
  1332.   DosInit;
  1333. end.
  1334.