home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / Pascal / MAXONPASCAL3.DMS / in.adf / DEMOS-OS1.3 / Datei.p < prev    next >
Encoding:
Text File  |  1994-07-23  |  13.1 KB  |  487 lines
  1. Program AddrMat;
  2.  
  3. {  Eine kleine Adressdatei.           }
  4. {                                     }
  5. {  Geschrieben von :                  }
  6. {  Jens "Himpel" Gelhar 1989          }
  7. {  als Demo für Himpel-/Kickpascal    }
  8.  
  9. { MaxonPascal3-Anpassung / Test:   Falk Zühlsdorff (PackMAN) 1994 }
  10.  
  11. { Dieses Programm demonstriert u. a. die Ein-/Ausgabeoperationen.
  12.   Um die Anwendung der Dateibefehle zu zeigen, wird die Datei
  13.   nicht in den Speicher geladen, sondern ausschließlich auf der
  14.   Disk bearbeitet. Dies schränkt die Möglichkeiten des Programms
  15.   natürlich stark ein.                                            }
  16.  
  17.  
  18. Label Ende1;
  19.   { Labels sollten nur verwendet werden, wenn der "normale"
  20.     Programmablauf unterbrochen wird. Das Label 'Ende1' steht
  21.     kurz vor dem Ende des Hauptprogramms und wird angesprungen,
  22.     wenn bei der Eingabe des Dateinamens ESC gedrückt wird.     }
  23.  
  24.  
  25. Const
  26.   CSI = chr($9b);       { Steuersequenzen-Einleiter }
  27.  
  28.   CrsrUp   = chr(1);    { Da bei Betätigung der Cursortasten            }
  29.   CrsrDown = chr(2);    { ganze Escape-Sequenzen gesendet werden, die   }
  30.   CrsrLeft = chr(3);    { umständlich zu handhaben sind, werden sie     }
  31.   CrsrRigth= chr(4);    { von der GETKEY-Prozedur in diese Codes gewandelt. }
  32.   BackSpace= chr(8);
  33.   LF       = chr(10);
  34.   CR       = chr(13);
  35.   Esc      = chr(27);
  36.   Del      = chr($7f);
  37.  
  38. Type
  39.   Anrede = (Herr, Frau, Firma, Ungueltig);
  40.  
  41.   Person=Record         { der Hauptdatentyp }
  42.            Anr: Anrede;
  43.            VName,NName: String[30]
  44.            Telefon: String[20]
  45.            Strasse: String[30]
  46.            Hausnr:  integer
  47.            Plz:     0..9999
  48.            Ort:     String[12];
  49.          End;
  50.  
  51.   Datei = File of Person;
  52.  
  53.   StrTyp = String;      { Für Parameterübergaben. Denn: "String" ist }
  54.                         { kein Typbezeichner, sondern ein Symbol!    }
  55.  
  56. Var
  57.   fname: StrTyp;        { Dateiname }
  58.   f: Datei;             { die Datei }
  59.   fs: Long;             { Speicher für "filesize(f)" }
  60.   Menu: Char;           { Im Hauptmenü eingegebenes Zeichen }
  61.   Win, Con: Ptr;        { Windowhandle und Console-Device }
  62.   Out: String;          { Ausgabepuffer für "WriteCon" }
  63.  
  64.  
  65. Procedure WriteC(s: Str);
  66.   { String "s" über Console.device ausgeben }
  67.   Begin
  68.     WriteCon(con,s)
  69.   End;
  70.  
  71.  
  72. Procedure SetXY(x,y: integer);
  73.   { GotoXY-Ersatz für ConDevice }
  74.   Var h: String;
  75.   Begin
  76.     h := CSI + IntStr(y) + ';' + intStr(x) + 'H';
  77.     WriteCon(Con,h)
  78.   End;
  79.  
  80.  
  81. Function WaitKey: Char;
  82.   { Auf Tastencode warten und zurückgeben }
  83.   Var c: Char;
  84.       Sig: Long;
  85.   Begin
  86.     Repeat
  87.       c := ReadCon(Con);
  88.       If c = #0 Then Sig := Wait(-1)
  89.     Until c <> chr(0);
  90.     WaitKey := c
  91.   End;
  92.  
  93.  
  94. Function GetKey: Char;
  95.   { Taste lesen und Sequenzen wandeln }
  96.   Var c: Char;
  97.  
  98.     Procedure CSIHandler;
  99.       Var s: String;
  100.       Begin
  101.         s:='';
  102.         Repeat           { Sequenz zeichenweise lesen }
  103.           s:=s+WaitKey
  104.         Until (Length(s)>=50) or ( s[Length(s)] >= '@');
  105.         If s='A' Then GetKey := CrsrUp          Else
  106.         If s='B' Then GetKey := CrsrDown        Else
  107.         If s='C' Then GetKey := CrsrRigth       Else
  108.         If s='D' Then GetKey := CrsrLeft        Else
  109.                       GetKey := chr(0)
  110.       End;
  111.  
  112.   Begin
  113.     c := WaitKey;
  114.     If c in [ chr(32).. chr(126), chr(160)..chr(255) ] Then
  115.       GetKey := c       { druckbares Zeichen }
  116.     Else
  117.       Case c Of
  118.         chr(8):  GetKey := BackSpace;
  119.         chr(13): GetKey := CR;
  120.         chr(27): GetKey := Esc;
  121.         chr($7f):GetKey := Del;
  122.         CSI:     CSIHandler;
  123.       Otherwise
  124.         Getkey := chr(0)
  125.       End;
  126.   End;
  127.  
  128.  
  129. Procedure FindEnd( Var st: StrTyp, i: integer);
  130.   { Ende von s[1] .. s[i] suchen, mit Nullbyte markieren }
  131.   Begin
  132.     While (i>1) and (st[i]=' ') Do
  133.       i:=pred(i);
  134.     st[ i + ord(st[i]<>' ') ] := chr(0)
  135.   End;
  136.  
  137.  
  138. Function LinEd( Var s: Strtyp, x0,y0,max: integer, Var x: integer): Char;
  139.   { String "s" mit der Höchstlänge "max" an Position (x0,y0) edieren. }
  140.   { x: Cursorposition innerhalb Zeile. }
  141.   { zurückgeben: letztes eingegebenes Zeichen (CR, Esc oder Up/Down }
  142.   Var i: integer;
  143.       c: Char;
  144.       ende: Boolean;
  145.   Begin
  146.     SetXY(x0, y0);      { an angegebener Position... }
  147.     writec(s);          { String ausgeben und...     }
  148.     writec(#e'K');      { Rest der Zeile löschen.    }
  149.     For i:=Length(s)+1 to max Do
  150.       s[i]:=' ';        { String mit Spaces auffüllen }
  151.     s[max+1] := chr(0); { ...und mit Nullbyte abschließen. }
  152.     SetXY(x0+x-1, y0);
  153.     ende := false;
  154.  
  155.     Repeat              { Zeileneditor-Hauptschleife }
  156.       c := GetKey;
  157.       If c in [chr(32)..chr(126), chr(160)..chr(255) ] Then
  158.         If x < max Then
  159.           Begin
  160.             For i:=max DownTo x+1 do    { Platz machen }
  161.               s[i] := s[i-1];
  162.             s[x] := c;                  { und Zeichen einfügen. }
  163.             x := x+1;
  164.             writecon(con, #e'@');       { Ein Zeichen auf Bildschirm einfügen }
  165.             writecon(con, c)            { und Zeichen ausgeben. }
  166.           End
  167.         Else
  168.       Else      { kein darstellbares Zeichen }
  169.         Case c Of
  170.          CR, Esc, CrsrUp, CrsrDown:     { mit diesen Tasten wird der }
  171.                    Ende := true;        { Editor verlassen.          }
  172.          BackSpace:If x>1 Then
  173.                       Begin
  174.                         x:=pred(x);
  175.                         For i:=x to max-1 do s[i] := s[i+1];
  176.                         s[max]:=' ';
  177.                         writecon(con, #8\e'P')
  178.                       End;
  179.          CrsrLeft: If x>1 Then
  180.                       Begin
  181.                         x := pred(x);
  182.                         writecon(con, #e'D')
  183.                       End;
  184.          CrsrRigth: If x<max Then
  185.                       Begin
  186.                         x := succ(x);
  187.                         writecon(con, #e'C')
  188.                       End;
  189.          Del:       Begin
  190.                       For i:=x to max-1 do s[i] := s[i+1];
  191.                       s[max]:=' ';
  192.                       writecon(con, #e'P')
  193.                     End;
  194.         Otherwise End;
  195.  
  196.     Until ende;
  197.  
  198.     FindEnd( s , max);  { Spaces am zeilenende abschneiden }
  199.     LinEd := c          { Zeichen zurückgeben }
  200.   End;
  201.  
  202.  
  203. Procedure Ausgabe1(p: Person);
  204.   { mit Feldnamen ausgeben }
  205.   Var s:String;
  206.   Begin
  207.     With p do
  208.       Begin
  209.         WriteC('Anrede: (HFG)  ');
  210.           Case Anr Of
  211.             Herr: WriteC("Herr");
  212.             Frau: WriteC("Frau");
  213.             Firma: WriteC("Firma")
  214.           Otherwise End;
  215.         WriteC(#e'K'\10'Vorname:       '); If Anr<>Firma Then WriteC(VName);
  216.         WriteC(#e'K'\10'Nachname:      '); writeC(NName);
  217.         WriteC(#e'K'\10'Telefon:       '); writeC(Telefon);
  218.         WriteC(#e'K'\10'Strasse:       '); writeC(Strasse);
  219.         WriteC(#e'K'\10'Nr.:           '); s := IntStr(HausNr); If HausNr>=0 Then writeC(s);
  220.         WriteC(#e'K'\10'Plz.:          '); s := IntStr(Plz); If plz<>0 Then writeC(s);
  221.         WriteC(#e'K'\10'Ort:           '); writeC(Ort);
  222.       End
  223.   End;
  224.  
  225.  
  226. Procedure Edit(Var p:Person);
  227.   Var buf: String;
  228.       Zeile: integer;
  229.       z,s,m: integer;
  230.       c: Char;
  231.   Begin
  232.     SetXY(1,4);
  233.     Ausgabe1(p);
  234.     Zeile:=1;
  235.  
  236.     Repeat
  237.       If Zeile=1 Then
  238.         Repeat
  239.           SetXY(16,4);
  240.           Case p.Anr Of
  241.             Herr:  writeC("Herr");
  242.             Frau:  writeC("Frau");
  243.             Firma: writeC("Firma");
  244.             Otherwise
  245.           End;
  246.           writeC(#e"K");
  247.  
  248.           Repeat
  249.             c:=GetKey
  250.           Until Upcase(c) in ["H","F","G",CR,CrsrUp,CrsrDown,Esc];
  251.  
  252.           Case Upcase(c) Of
  253.            "H": p.Anr := Herr;
  254.            "F": p.Anr := Frau;
  255.            "G": p.Anr := Firma;
  256.            Otherwise;
  257.           End;
  258.  
  259.         Until (c in [CR, CrsrUp, CrsrDown, Esc]) and (p.Anr<>Ungueltig)
  260.       Else
  261.       If (Zeile=2) and (p.Anr=Firma) Then
  262.         Begin p.VName :=""; SetXY(16,5); writeC(#e'K') End
  263.       Else
  264.         Begin
  265.           With p Do
  266.             Case Zeile Of
  267.             2: Begin z:=29; buf:=VName End;
  268.             3: Begin z:=29; buf:=NName End;
  269.             4: Begin z:=19; buf:=Telefon End;
  270.             5: Begin z:=29; buf:=Strasse End;
  271.             6: Begin z:=20;
  272.                      If HausNr<0 Then buf:='' Else buf:=IntStr(HausNr) End;
  273.             7: Begin z:=20;
  274.                      If Plz<=0 Then buf:='' Else buf:=IntStr(plz) End;
  275.             8: Begin z:=11; buf:=Ort End;
  276.             End;
  277.           s:=1;
  278.           Repeat
  279.             c:=LinEd(buf,16,Zeile+3,z,s);
  280.             If (Zeile=6) and (buf<>'') Then
  281.               Begin
  282.                 Val(buf,p.HausNr,m);
  283.                 If (m<>0) or (p.HausNr<0) Then c:=" "
  284.               End;
  285.             If (Zeile=7) and (buf<>'') Then
  286.               Begin
  287.                 Val(buf,p.Plz,m);
  288.                 If (m<>0) or (p.Plz<1000) or (p.Plz>9999) Then c:=" "
  289.               End;
  290.           Until c in [CR, CrsrUp, CrsrDown, Esc];
  291.           With p Do
  292.             Case Zeile Of
  293.             2: VName:=buf;
  294.             3: Nname:=buf;
  295.             4: Telefon:=buf;
  296.             5: Strasse:=buf;
  297.             8: Ort:=buf
  298.             Else
  299.             End;
  300.         End;
  301.       If c in [cr, CrsrDown] Then Zeile:=Zeile+1
  302.       Else
  303.         If c=CrsrUp Then Zeile:=Zeile-1;
  304.     Until (Zeile=9) or (Zeile=0) or (c=Esc);
  305.     writeC(LF)
  306.   End;
  307.  
  308.  
  309. Procedure Eingabe(Var p: Person);
  310.   Begin
  311.     WriteC(#12#10'Bitte Daten eingeben!'#10#10);
  312.     With p do
  313.       Begin
  314.         Anr := UnGueltig;
  315.         VName := "";
  316.         NName := "";
  317.         Telefon := "";
  318.         Strasse := "";
  319.         HausNr := -1;
  320.         Plz := 0;
  321.         Ort := "";
  322.       End;
  323.     Edit(p)
  324.   End;
  325.  
  326.  
  327. Procedure Ausgabe(p: Person);
  328.   Var s: string[1000];
  329.   Begin
  330.     With p DO
  331.       Begin
  332.         Case Anr of
  333.           Herr: s := 'Herr '+VName
  334.           Frau: s := 'Frau '+VName
  335.           Firma:s := 'Firma '
  336.         Otherwise
  337.           error('Datenfehler!!');
  338.         End;
  339.        s := LF + s + " " + NName + LF + 'Tel. ' + Telefon + LF + Strasse
  340.                + ' ' + IntStr(HausNR) + LF + IntStr(plz) + ' ' + Ort;
  341.        writecon(con,s);
  342.       End
  343.   End;
  344.  
  345.  
  346. Procedure Ergänzen;
  347.   Var per: Person;
  348.   Begin
  349.     If Filepos(f)<>Filesize(f) Then
  350.       Seek(f,Filesize(f));
  351.     Eingabe(Per);
  352.     write(f,Per)
  353.   End;
  354.  
  355. Procedure Blättern;
  356.   Var per: Person;
  357.       i: Long;
  358.       c: Char;
  359.   Begin
  360.     i := 0;
  361.     Repeat
  362.       writeC(LF);
  363.       Seek(f,i);
  364.       read(f,per);
  365.       Out := #12#10"Datensatz Nr. " + IntStr(i+1);
  366.       If eof(f) Then Out := Out + " - Dateiende";
  367.       Out := Out + LF + LF;
  368.       WriteC(Out);
  369.       Ausgabe1(per);
  370.       writeC(#10\10'SPACE=weiter BACKSPACE=zurück RETURN=Edit ESC=Ende : ');
  371.       Repeat
  372.         c := GetKey
  373.       Until c in [" ",Esc,BackSpace,CR];
  374.       Case c Of
  375.        " ":       If i<filesize(f) Then i:=i+1;
  376.        BackSpace: If i>0 Then i:=i-1;
  377.        CR:        Begin SetXY(1,2); WriteC("Edit"\e"K"); Edit(per);
  378.                         Seek(f,i); write(f,per)
  379.                   End;
  380.       Otherwise
  381.       End;
  382.     Until (c=Esc) or (i=Filesize(f))
  383.   End;
  384.  
  385.  
  386. Procedure DateiAusgeben;
  387.   Var p1,p2: Person; c:Char; i: integer;
  388.   Begin
  389.     Seek(f,0);
  390.     While not eof(f) Do
  391.       Begin
  392.         read(f,p1);    { get(f); p1:=f^ }
  393.         Ausgabe(p1);
  394.         i:=i+1;
  395.         writecon(con,LF)
  396.       End;
  397.     writecon(con,#10'Bitte Taste drücken!  ');
  398.     While ReadCon(con)<>chr(0) do ;   { "Tastenpuffer" leeren }
  399.     c := GetKey
  400.   End;
  401.  
  402.  
  403. Procedure Dateiname;
  404.   Var c: Char;
  405.       L: integer;
  406.       x: integer;
  407.       OK: Boolean;
  408.   Begin
  409.     Repeat
  410.       x := 1;
  411.       fname := '';
  412.       SetXY(1,2);
  413.       writecon(con,'Dateiname: ');
  414.       Repeat
  415.         c:=LinEd(fname,12,2,60,x)
  416.       Until ((fname<>'') and (c=CR)) or (c=Esc);
  417.       If c=Esc Then Goto Ende1;
  418.       WriteCon(con,LF);
  419.       L := Length(fname);
  420.       If L > 4 Then
  421.         If fname[L-3]<>'.' Then
  422.           fname:=fname+'.dat';
  423.       reset(f,fname);
  424.       If IOResult=0 Then
  425.         Exit
  426.       Else
  427.         Begin
  428.           Out := (LF+LF+'Datei '+fname+' existiert nicht.'$a$a'Anlegen? ');
  429.           WriteCon(Con, Out);
  430.           Repeat
  431.             c := GetKey
  432.           Until c in ["J","j","N","n"];
  433.           If Upcase(c)="J" Then
  434.             Begin
  435.               Rewrite(f,fname);
  436.               If IOResult<>0 Then
  437.                  WriteCon(Con, #$0a$0a'Datei konnte nicht angelegt werden.')
  438.               Else
  439.                 Begin
  440.                   Close(f);
  441.                   Reset(f,fname);
  442.                   Exit
  443.                 End
  444.             End
  445.         End
  446.     Until false
  447.   End;
  448.  
  449.  
  450.  
  451. Begin  { Main }
  452.   Win:=Open_Window(0,0,640,200,1,0,$1006,'Himpels very special Database',Nil,640,200,640,255);
  453.   Con:=OpenConsole(Win);
  454.   Dateiname;
  455.   Repeat
  456.     fs := Filesize(f);
  457.     WriteCon(con,chr(12));    { Bildschirm löschen }
  458.     Case fs of
  459.       0: writecon(con, 'Datei ist leer.');
  460.       1: writecon(con, 'Datei enthält einen Datensatz');
  461.     Otherwise
  462.       Out:='Datei enthält '+IntStr(fs)+' Datensätze';
  463.       writecon(con, Out)
  464.     End;
  465.     writecon(con,''\10\10\&
  466.          \e'33mA'\e'31m  Daten hinzufügen'\10\&
  467.          \e'33mB'\e'31m  Blättern'\10\&
  468.          \e'33mL'\e'31m  Adressliste ausgeben'\10\&
  469.          \e'33mQ'\e'31m  Programmende'\10\10'--> ');
  470.  
  471.     Menu:=GetKey;
  472.  
  473.     Case Upcase(Menu) Of
  474.       'A': Ergänzen;
  475.       'B': Blättern;
  476.       'L': DateiAusgeben;
  477.     Otherwise ;
  478.     End;
  479.   Until Upcase(Menu) = 'Q';
  480.   writecon(con,#10#10'Tschüß!');
  481.   Close(f);
  482. Ende1:
  483.   CloseConsole(Con);
  484.   Close_Window(Win);
  485. End.
  486.  
  487.