home *** CD-ROM | disk | FTP | other *** search
/ Beijing Paradise BBS Backup / PARADISE.ISO / software / BBSDOORW / ARGUS161.ZIP / ARGUSDEM.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1995-04-03  |  15.3 KB  |  552 lines
  1. Program ArgusDem;
  2. { -------- mit Turbo-Pascal 6.0 oder höher übersetzen -------- }
  3. { ---------- compile with Turbo-Pascal 6.0 or above ---------- }
  4.  
  5. {$M 4096,0,4096}              { Speicher begrenzen ! }
  6. {$X+,R-,V-,I-,A+,G+,S-,D-,L-}
  7. Uses Dos,Crt,EMS;
  8.  
  9. var  F1,F2 : Text;
  10.      S     : String;
  11.      V     : Word;
  12.      Handle1,Handle2,Handle3,
  13.      Size,Free,io : Integer;
  14.      deutsch  : Boolean;
  15.      ch,Drive : Char;
  16.  
  17. Const Name1 : String = 'argus.aaa';
  18.       Name2 : String = 'argus.bbb';
  19.       Name3 : String = 'argus.ccc';
  20.  
  21.  
  22. Function HexStr(w : Word):String;
  23. const HexTab : Array[0..15] of Char = '0123456789ABCDEF';
  24. begin
  25.   HexStr := HexTab[w shr 12] + HexTab[(w shr 8) and $F] +
  26.             HexTab[(w shr 4) and $F] + HexTab[w and $F] + 'h';
  27. end;
  28.  
  29. Procedure SetHandles(Count: Integer); assembler;
  30. { Anzahl der Handles festlegen }
  31. asm
  32.   mov  bx,Count
  33.   mov  ah,067h
  34.   int  21h
  35. end;
  36.  
  37. Procedure SetDrive(drive: Char); assembler;
  38. { Laufwerk wählen }
  39. asm
  40.   mov  ah,00Eh
  41.   mov  dl,drive
  42.   sub  dl,'A'
  43.   int  21h
  44. end;
  45.  
  46. Function CurrentDrive: Char; assembler;
  47. { Laufwerk wählen }
  48. asm
  49.   mov  ah,019h
  50.   int  21h
  51.   add  al,'A'
  52. end;
  53.  
  54. Procedure Wait; assembler;   { Warte ca. 0.7 Sekunden }
  55. asm
  56.           mov   cx,0050      { 50 Video-Bilder abwarten }
  57.           mov   dx,$03DA
  58. @VSy0:    in    al,dx        { Warte auf Ende Bildrücklauf }
  59.           test  al,8
  60.           jnz   @VSy0
  61. @VSy1:    in    al,dx        { Warte auf Anfang Bildrücklauf }
  62.           test  al,8
  63.           jz    @VSy1
  64.           loop  @VSy0
  65. end;
  66.  
  67. begin
  68.   Name1[Length(Name1)+1] := #0;  { DOS-Strings }
  69.   Name2[Length(Name2)+1] := #0;  { DOS-Strings }
  70.   Name3[Length(Name3)+1] := #0;  { DOS-Strings }
  71.  
  72.   { Hilfe anzeigen }
  73.   write('Do you want German messages ? (y/n) : n'^H);
  74.   ch := UpCase(ReadKey);
  75.   Deutsch := (ch = 'Y') or (ch = 'J') or (ch = ' ');
  76.   Writeln(ch);
  77.   Writeln;
  78.   if Deutsch then
  79.     Writeln('Vor dem Start dieses Programmes ARGUS.COM wie folgt aufrufen :')
  80.   else
  81.     Writeln('Bevor running this program call ARGUS.COM as follows:');
  82.   Writeln;
  83.   Writeln('    ARGUS /a/c');
  84.   Writeln;
  85.   Wait; Wait;
  86.  
  87.   Drive := CurrentDrive;
  88.   if Deutsch then begin
  89.     Writeln('Aktuelles Laufwerk : ',Drive,':');
  90.     Writeln('Wechsel auf A:');
  91.     end
  92.   else begin
  93.     Writeln('current drive : ',Drive,':');
  94.     Writeln('change to A:');
  95.   end;
  96.   SetDrive('A');
  97.   if Deutsch then
  98.     Writeln('auf A: sind ',DiskFree(0),' Bytes frei')
  99.   else
  100.     Writeln('on  A: are  ',DiskFree(0),' Bytes free');
  101.   if Deutsch then
  102.     Writeln('Wechsel auf ',Drive)
  103.   else begin
  104.     Writeln('change to ',Drive);
  105.   end;
  106.   SetDrive(Drive);
  107.   if Deutsch then
  108.     Writeln('auf ',Drive,': sind ',DiskFree(0),' Bytes frei')
  109.   else
  110.     Writeln('on  ',Drive,':  are ',DiskFree(0),' Bytes free');
  111.   writeln;
  112.   Wait;
  113.  
  114.   SetHandles(30);   { max. 30 Dateien }
  115.  
  116.   MkDir('argus.dem');
  117.   io := IOResult;
  118.   if Deutsch then
  119.     Writeln('Verzeichnis erstellen : ARGUS.DEM , Result = ',io)   { ok }
  120.   else
  121.     Writeln('create directory      : ARGUS.DEM , Result = ',io);  { ok }
  122.   wait;
  123.  
  124.   ChDir('argus.dem');
  125.   io := IOResult;
  126.   if Deutsch then
  127.     Writeln('Verzeichnis wechseln  : ARGUS.DEM , Result = ',io)   { ok }
  128.   else
  129.     Writeln('change directory      : ARGUS.DEM , Result = ',io);  { ok }
  130.   wait;
  131.  
  132.   GetDir(0,S);    { aktuelles Laufwerk }
  133.   if Deutsch then
  134.     Writeln('Aktuelles Verzeichnis : ',S)
  135.   else
  136.     Writeln('current directory     : ',S);
  137.   wait;      { ok }
  138.  
  139.   RmDir(S);
  140.   io := IOResult;
  141.   if Deutsch then
  142.     Writeln('Verzeichnis löschen   : ',S,' , Result = ',io)       { fail }
  143.   else
  144.     Writeln('delete directory      : ',S,' , Result = ',io);      { fail }
  145.   wait;
  146.  
  147.   Assign(f1,Name1);
  148.   ReWrite(f1);
  149.   io := IOResult;
  150.   if Deutsch then
  151.     Writeln('Datei anlegen         : ',Name1,' , Result = ',io)   { ok }
  152.   else
  153.     Writeln('create file           : ',Name1,' , Result = ',io);  { ok }
  154.   wait;
  155.   Writeln(f1,Name1,' -------------------- ',Name1);
  156.   Writeln(f1,Name1,' -------------------- ',Name1);
  157.  
  158.   Assign(f2,Name2);
  159.   ReWrite(f2);
  160.   io := IOResult;
  161.   if Deutsch then
  162.     Writeln('Datei anlegen         : ',Name2,' , Result = ',io)   { ok }
  163.   else
  164.     Writeln('create file           : ',Name2,' , Result = ',io);  { ok }
  165.   wait;
  166.   Writeln(f2,Name2);
  167.  
  168.   Flush(f2);      { TP-Flush ! }
  169.   io := IOResult;
  170.   if Deutsch then
  171.     Writeln('Datei sichern         : ',Name2,' , Result = ',io)   { ok }
  172.   else
  173.     Writeln('flush file            : ',Name2,' , Result = ',io);  { ok }
  174.   wait;
  175.  
  176.   Close(f1);
  177.   io := IOResult;
  178.   if Deutsch then
  179.     Writeln('Datei schließen       : ',Name1,' , Result = ',io)   { ok }
  180.   else
  181.     Writeln('close file            : ',Name1,' , Result = ',io);  { ok }
  182.   wait;
  183.  
  184.   Close(f1);
  185.   io := IOResult;
  186.   if Deutsch then
  187.     Writeln('Datei schließen       : ',Name1,' , Result = ',io)   { fail }
  188.   else
  189.     Writeln('close file            : ',Name1,' , Result = ',io);  { fail }
  190.   wait;
  191.  
  192.   ChDir('..');
  193.   io := IOResult;
  194.   if Deutsch then
  195.     Writeln('Verzeichnis wechseln  : ..        , Result = ',io)   { ok }
  196.   else
  197.     Writeln('change directory      : ..        , Result = ',io);  { ok }
  198.   wait;
  199.  
  200.   GetDir(0,S);
  201.   if Deutsch then
  202.     Writeln('Aktuelles Verzeichnis : ',S)
  203.   else
  204.     Writeln('current directory     : ',S);
  205.   wait;      { ok }
  206.  
  207.   RmDir('argus.dem');
  208.   io := IOResult;
  209.   if Deutsch then
  210.     Writeln('Verzeichnis löschen   : ..        , Result = ',io)   { fail }
  211.   else
  212.     Writeln('remake directory      : ..        , Result = ',io);  { fail }
  213.   wait;
  214.  
  215.   ChDir('argus.dem');
  216.   io := IOResult;
  217.   if Deutsch then
  218.     Writeln('Verzeichnis wechseln  : ARGUS.DEM , Result = ',io)   { ok }
  219.   else
  220.     Writeln('change directory      : ARGUS.DEM , Result = ',io);  { ok }
  221.   wait;
  222.  
  223.   Assign(f1,Name3);
  224.   Reset(f1);
  225.   io := IOResult;
  226.   if Deutsch then
  227.     Writeln('Datei öffnen          : ',Name3,' , Result = ',io)   { fail }
  228.   else
  229.     Writeln('open file             : ',Name3,' , Result = ',io);  { fail }
  230.   wait;
  231.  
  232.   Assign(f1,Name1);
  233.   Reset(f1);
  234.   io := IOResult;
  235.   if Deutsch then
  236.     Writeln('Datei öffnen          : ',Name1,' , Result = ',io)   { ok }
  237.   else
  238.     Writeln('open file             : ',Name1,' , Result = ',io);  { ok }
  239.   wait;
  240.  
  241.   Close(f2);
  242.   io := IOResult;
  243.   if Deutsch then
  244.     Writeln('Datei schließen       : ',Name2,' , Result = ',io)   { ok }
  245.   else
  246.     Writeln('close file            : ',Name2,' , Result = ',io);  { ok }
  247.   wait;
  248.  
  249.   Erase(f2);
  250.   io := IOResult;
  251.   if Deutsch then
  252.     Writeln('Datei löschen         : ',Name2,' , Result = ',io)   { ok }
  253.   else
  254.     Writeln('erase file            : ',Name2,' , Result = ',io);  { ok }
  255.   wait;
  256.  
  257.   Close(f1);
  258.   io := IOResult;
  259.   if Deutsch then
  260.     Writeln('Datei schließen       : ',Name1,' , Result = ',io)   { ok }
  261.   else
  262.     Writeln('close file            : ',Name1,' , Result = ',io);  { ok }
  263.   wait;
  264.  
  265.   asm
  266.     lea si,[Name1+1]   { File1 über erweiterte Open-Funktion ansprechen }
  267.     mov bx,0001        { WO }
  268.     xor cx,cx
  269.     mov dx,0010h       { Datei erzeugen, nicht überschreiben }
  270.     mov ax,6C00h       { erweitertes Open }
  271.     int 21h            { sollte Fehler geben }
  272.     mov bx,0001        { WO }
  273.     xor cx,cx
  274.     mov dx,0012h       { Datei erzeugen, überschreiben }
  275.     mov ax,6C00h       { erweitertes Open }
  276.     int 21h            { das sollte funktionieren ! }
  277.     jc  @Err
  278.     mov bx,ax
  279.     mov cx,12345
  280.     mov ah,040h
  281.     int 21h
  282.     mov ah,03Eh
  283.     int 21h            { Datei schließen }
  284.   @Err:
  285.   end;
  286.  
  287.   Erase(f1);
  288.   io := IOResult;
  289.   if Deutsch then
  290.     Writeln('Datei löschen         : ',Name1,' , Result = ',io)   { ok }
  291.   else
  292.     Writeln('erase file            : ',Name1,' , Result = ',io);  { ok }
  293.   wait;
  294.  
  295.  
  296.   asm
  297.     lea si,[Name1+1]   { File1 über erweiterte Open-Funktion ansprechen }
  298.     mov bx,0001        { WO }
  299.     xor cx,cx
  300.     mov dx,0001h       { Datei öffnen, Fehler bei nicht ex. }
  301.     mov ax,6C00h       { erweitertes Open }
  302.     int 21h            { sollte Fehler geben }
  303.     mov bx,0001        { WO }
  304.     xor cx,cx
  305.     mov dx,0010h       { Datei erzeugen, nicht überschreiben }
  306.     mov ax,6C00h       { erweitertes Open }
  307.     int 21h            { das sollte funktionieren ! }
  308.     jc  @Err
  309.     mov bx,ax
  310.     mov ah,03Eh
  311.     int 21h            { Datei schließen }
  312.     lea dx,[Name1+1]
  313.     mov ah,41h         { Datei löschen }
  314.     int 21h
  315.   @Err:
  316.   end;
  317.  
  318.   ChDir('..');
  319.   io := IOResult;
  320.   if Deutsch then
  321.     Writeln('Verzeichnis wechseln  : ..        , Result = ',io)   { ok }
  322.   else
  323.     Writeln('change directory      : ..        , Result = ',io);  { ok }
  324.   wait;
  325.  
  326.   RmDir('argus.dem');
  327.   io := IOResult;
  328.   if Deutsch then
  329.     Writeln('Verzeichnis löschen   : ARGUS.DEM , Result = ',io)   { ok }
  330.   else
  331.     Writeln('remake directory      : ARGUS.DEM , Result = ',io);  { ok }
  332.   wait;
  333.  
  334.   GetDir(0,S);
  335.   if Deutsch then
  336.     Writeln('Aktuelles Verzeichnis : ',S)   { ok }
  337.   else
  338.     Writeln('current directory     : ',S);  { ok }
  339.   wait;
  340.  
  341.   S := S+'\'#0;       { aktuelles Verzeichnis ! }
  342.   asm
  343.     mov  ah,05Ah      { temporäre Datei erstellen }
  344.     xor  cx,cx        { Attribute }
  345.     mov  dx,offset S
  346.     inc  dx
  347.     int  21h
  348.     mov  bx,ax
  349.     mov  Handle1,bx
  350.     mov  di,offset S
  351.     mov  si,di
  352.     inc  di
  353.     mov  cx,ds
  354.     mov  es,cx
  355.     mov  cx,$0100
  356.     xor  al,al
  357.     REPNE scasb       { suche 0 (Abschluß des Namens) }
  358.     neg  cx
  359.     add  cx,$0FF
  360.     mov  [si],cl      { Stringlänge ok }
  361.  
  362.     mov  ah,040h
  363.     mov  dx,0
  364.     mov  cx,50000     { schreibe 50000 Bytes }
  365.     int  21h
  366.  
  367.     mov  ah,068h      { flush file }
  368.     int  21h
  369.  
  370.     mov  ah,040h      { weitere 50000 Bytes }
  371.     int  21h
  372.  
  373.     mov  ah,03Eh      { wieder schließen }
  374.     int  21h
  375.     mov  dx,si
  376.     inc  dx
  377.     mov  ah,041h      { wieder löschen }
  378.     int  21h
  379.   end;
  380.   if Deutsch then
  381.     Writeln('temporäre Datei ',S,' Handle = ',Handle1)       { ok }
  382.   else
  383.     Writeln('temporary file  ',S,' Handle = ',Handle1);      { ok }
  384.  
  385.   if EMS_avail then begin
  386.     Writeln;
  387.     V := GetEMSVersion;
  388.     if Deutsch then
  389.       Writeln('EMS Version ',Hi(V),'.',Lo(V),' vorhanden -> EMS-Test')
  390.     else
  391.       Writeln('EMS Version ',Hi(V),'.',Lo(V),' available -> EMS test');
  392.     wait;
  393.     Writeln;
  394.     if Deutsch then
  395.       Writeln('EMS Seitenrahmen auf ',HexStr(EMSPageFrame))
  396.     else
  397.       Writeln('EMS page frame on    ',HexStr(EMSPageFrame));
  398.  
  399.     GetEMSSize(Size, Free);
  400.     if Deutsch then
  401.       Writeln('von ',Size,' Seiten sind noch ',Free,' frei.')
  402.     else
  403.       Writeln('from ',Size,' pages are still ',Free,' free.');
  404.     wait;
  405.  
  406.     if Deutsch then
  407.       Writeln('Es sind im Moment ',GetEMSHandles,' EMS-Handles vergeben.')
  408.     else
  409.       Writeln('At current time are ',GetEMSHandles,' EMS handles requested.');
  410.     wait;
  411.  
  412.     if GetEMSMem(Free shr 1 , Handle1) then begin
  413.       if Deutsch then
  414.         Writeln(Free shr 1,' Seiten auf EMS-Handle ',Handle1,' angefordert.')
  415.       else
  416.         Writeln(Free shr 1,' pages  to  EMS handle ',Handle1,' requested.');
  417.     end;
  418.     wait;
  419.  
  420.     if Deutsch then
  421.       Writeln('EMS-Handle ',Handle1,' benutzt ',GetEMSPages(Handle1),' Seiten.')
  422.     else
  423.       Writeln('EMS handle ',Handle1,'  uses   ',GetEMSPages(Handle1),' pages.');
  424.     wait;
  425.  
  426.     if SetEMSMapping(Handle1, 2, 1) then begin
  427.       if Deutsch then
  428.         Writeln('EMS-Handle ',Handle1,' Seite 1 auf Seitenrahmen 2 geladen.')
  429.       else
  430.         Writeln('EMS handle ',Handle1,' page  1 into page frame 2 loaded.');
  431.     end;
  432.     wait;
  433.  
  434.     if SetEMSMapping(Handle1, 0, Free shr 1) then begin
  435.       if Deutsch then
  436.         Writeln('EMS-Handle ',Handle1,' Seite ',Free shr 1,' auf Seitenrahmen 0 geladen.')
  437.       else
  438.         Writeln('EMS handle ',Handle1,' page  ',Free shr 1,' into page frame 0 loaded.');
  439.      end
  440.     else begin
  441.       if Deutsch then
  442.         Writeln('falsche logische Seite')     { dieser Fehler muß kommen }
  443.       else
  444.         Writeln('invalid logical page');      { this error has to come   }
  445.     end;
  446.     wait;
  447.  
  448.     if GetEMSMem(Free shr 1 , Handle2) then begin
  449.       if Deutsch then
  450.         Writeln(Free shr 1,' Seiten auf EMS-Handle ',Handle2,' angefordert.')
  451.       else
  452.         Writeln(Free shr 1,' pages  to  EMS handle ',Handle2,' requested.');
  453.     end;
  454.     wait;
  455.  
  456.     if Deutsch then
  457.       Writeln('EMS-Handle ',Handle2,' benutzt ',GetEMSPages(Handle2),' Seiten.')
  458.     else
  459.       Writeln('EMS handle ',Handle2,'  uses   ',GetEMSPages(Handle2),' pages.');
  460.     wait;
  461.  
  462.     if Deutsch then
  463.       Writeln('EMS-Handle 83 benutzt ',GetEMSPages(83),' Seiten.')
  464.     else
  465.       Writeln('EMS handle 83  uses   ',GetEMSPages(83),' pages.');
  466.     wait;
  467.  
  468.     if GetEMSMem(Free shr 1 , Handle3) then begin
  469.       if Deutsch then
  470.         Writeln(Free shr 1,' Seiten auf EMS-Handle ',Handle3,' angefordert.')
  471.       else
  472.         Writeln(Free shr 1,' pages  to  EMS handle ',Handle3,' requested.');
  473.      end
  474.     else begin
  475.       if Deutsch then
  476.         Writeln('kein freier Speicher mehr')   { dieser Fehler muß kommen }
  477.       else
  478.         Writeln('no free memory left');        { this error has to come   }
  479.     end;
  480.     wait;
  481.  
  482.     if GetEMSMem(0 , Handle3) then begin
  483.       if Deutsch then
  484.         Writeln('0 Seiten auf EMS-Handle ',Handle3,' angefordert.')
  485.       else
  486.         Writeln('0 pages  to  EMS handle ',Handle3,' requested.');
  487.      end
  488.     else begin
  489.       if Deutsch then
  490.         Writeln('0 Seiten angefordert')   { dieser Fehler muß kommen }
  491.       else
  492.         Writeln('0 pages requested');     { this error has to come   }
  493.     end;
  494.     wait;
  495.  
  496.     asm   mov  ah,$048; mov dx,Handle1; int  $67; end;
  497.     if Deutsch then
  498.       writeln('Mapping Handle ',Handle1,' rücksetzen.')      { fail }
  499.     else
  500.       writeln('reset mapping handle ',Handle1);              { fail }
  501.  
  502.     asm   mov  ah,$047; mov dx,Handle1; int  $67; end;
  503.     if Deutsch then
  504.       writeln('Mapping Handle ',Handle1,' gesichert.')        { ok }
  505.     else
  506.       writeln('save mapping handle ',Handle1);                { ok }
  507.  
  508.     asm   mov  ah,$047; mov dx,Handle1; int  $67; end;
  509.     if Deutsch then
  510.       writeln('Mapping Handle ',Handle1,' gesichert.')       { fail }
  511.     else
  512.       writeln('save mapping handle ',Handle1);               { fail }
  513.  
  514.     asm   mov  ah,$048; mov dx,Handle1; int  $67; end;
  515.     if Deutsch then
  516.       writeln('Mapping Handle ',Handle1,' rücksetzen.')       { ok }
  517.     else
  518.       writeln('reset mapping handle ',Handle1);               { ok }
  519.  
  520.     if FreeEMSMem(Handle1) then begin
  521.       if Deutsch then
  522.         Writeln('Speicher des Handle ',Handle1,' freigegeben.')
  523.       else
  524.         Writeln('memory  of  handle  ',Handle1,' released.');
  525.     end;
  526.     wait;
  527.  
  528.     if FreeEMSMem(Handle2) then begin
  529.       if Deutsch then
  530.         Writeln('Speicher des Handle ',Handle2,' freigegeben.')
  531.       else
  532.         Writeln('memory  of  handle  ',Handle2,' released.');
  533.     end;
  534.     wait;
  535.  
  536.     if FreeEMSMem(Handle2) then begin
  537.       if Deutsch then
  538.         Writeln('Speicher des Handle ',Handle2,' freigegeben.')    { fail }
  539.       else
  540.         Writeln('memory  of  handle  ',Handle2,' released.');
  541.     end;
  542.     wait;
  543.   end;  { if EMS_avail then .. }
  544.  
  545.   Writeln;
  546.   if Deutsch then
  547.     Writeln('Programm-Ende : Code = 123')
  548.   else
  549.     Writeln('exit program  : Code = 123');
  550.   Halt(123);
  551. end.
  552.