home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Misc / VIDEOTEXT.LZX / VTsrc / sys.p < prev    next >
Encoding:
Text File  |  1996-03-25  |  24.6 KB  |  733 lines
  1. UNIT sys; {$project vt}
  2. { Betriebssystemnahe Funktionen zum Programm VideoText }
  3.  
  4. INTERFACE;
  5.  
  6. TYPE str80 = String[80];
  7.  
  8. VAR taste: Char;
  9.     rawcode: Long;
  10.     newevent,mouseclicked,dblclicked,menupicked: Boolean;
  11.     clickedx,clickedy: Integer;
  12.     menucode: Long;
  13.     palette: ARRAY[0..7] OF Word;
  14.     colperm: Long;
  15.     Con: Ptr;  { darf nicht vom ExitServer geschlossen werden, komisch }
  16.  
  17. PROCEDURE event_scan;
  18. PROCEDURE check(code: Long; really: Boolean);
  19. FUNCTION has_check(code: Long): Boolean;
  20. FUNCTION ja_nein(message: Str): Boolean;
  21. PROCEDURE create_icon(VAR src,dest: str80);
  22. FUNCTION fileselect(was_los: str80; speichern: Boolean;
  23.                                    VAR selected: str80): Boolean;
  24. PROCEDURE desaster(meldung: Str80);
  25. PROCEDURE stretch_line(zeile, sp0, sp1: Integer);
  26. PROCEDURE raster_line(zeile, sp0, sp1: Integer; farbe: Word);
  27. PROCEDURE scroll_text(zl0,zl1, sp0,sp1, dy,dx: Integer);
  28. FUNCTION bitmapzeile(plane,line: Integer): Ptr;
  29. PROCEDURE busy_pointer;
  30. PROCEDURE normal_pointer;
  31. PROCEDURE showscreen(mine: Boolean);
  32. PROCEDURE getpalette;
  33. PROCEDURE telltime(VAR day,min,tic: Long);
  34. PROCEDURE force_time(VAR s: Str80);
  35. PROCEDURE start_clip(size: Long);
  36. PROCEDURE clip_it(s: Str; len: Long);
  37. PROCEDURE end_clip;
  38. PROCEDURE sysinit(version: Str);
  39. PROCEDURE sysclean;
  40.  
  41. { ---------------------------------------------------------------------- }
  42.  
  43. IMPLEMENTATION;
  44.  
  45. {$opt q,s+,i+ } { keine Laufzeitprüfungen außer Stack und Feldindizes }
  46. {$incl "intuition.lib", "graphics.lib" }
  47. {$incl "diskfont.lib", "dos.lib", "req.lib", "icon.lib", "asl.lib" }
  48. {$incl "exec.lib", "devices/timer.h", "devices/clipboard.h" }
  49. {$incl "devices/console.h", "consolehandle.h" }
  50.  
  51. TYPE WordArr36 = ARRAY [1..36] OF Word;
  52.      IntArr10 = ARRAY [1..10] OF Integer;
  53.  
  54. VAR NeuerScreen: ExtNewScreen;  STATIC;
  55.     MyScreen: p_Screen;
  56.     Tags: Array[1..10] OF TagItem;  STATIC;
  57.     titel: Str80;  STATIC;
  58.     NeuesWindow: NewWindow;  STATIC;
  59.     myprocess: p_Process;
  60.     MyWindow,oldwindowptr: p_Window;
  61.     Strip, LastMenu: p_Menu;
  62.     LastItem, LastSubItem: p_MenuItem;
  63.     topazAttr,teleAttr: TextAttr;
  64.     teleFont: p_TextFont;
  65.     nextselect: Word;
  66.     inpev: InputEvent;
  67.     lastmsg: IntuiMessage; { kein Zeiger! }
  68.     BusyPointerData: ^WordArr36;
  69.     { für die req.library: }
  70.     MyFileReq: p_ReqFileRequester;
  71.     pfad: Array[0..DSIZE] OF Char; STATIC;
  72.     name: Array[0..FCHARS] OF Char; STATIC;
  73.     pfadname: Array[-DSIZE..FCHARS] OF Char; STATIC;
  74.     { fürs clipboard.device: }
  75.     clip_port: ^MsgPort;
  76.     clipreq: ^IOClipReq; { erweiterte IO-Request-Struktur }
  77.     clip_open: Boolean;
  78.     { für den Aushilfs-Requester: }
  79.     MyRequest: Requester; STATIC;
  80.     TextGad: Gadget; STATIC;
  81.     TextInfo: StringInfo; STATIC;
  82.     ITxt: ARRAY[1..5] OF IntuiText; STATIC;
  83.     Borders: ARRAY[1..6] OF Border; STATIC;
  84.     TextBordXY,MainBordXY: IntArr10; STATIC;
  85.  
  86.  
  87. { PROCEDURE's desaster(), raster_line(), stretch_line() sowie die }
  88. { Menü-Erzeugung includen: }
  89. CONST unit_sys=1701; {$path "PAS:prg/vt/"; incl "dbluse.p" }
  90.  
  91. PROCEDURE event_scan;
  92. { überträgt eingehende Tasten und ESC-Sequenzen sowie die Intuition- }
  93. { Ereignisse Mausklick und Menuewahl in globale Variablen. }
  94. VAR Msg: ^IntuiMessage;
  95.     i,charx,chary: Integer;
  96.     pp: ^Ptr;
  97.     buf: String[10];
  98. PROCEDURE menu_eval(item: Word);
  99. { wird an zwei Stellen gebraucht ... }
  100. VAR men,menitem,subitem: Word;
  101.     item_address: ^MenuItem;
  102. BEGIN
  103.   newevent := True; menupicked := True;
  104.   { Menue, Menuepunkt und Untermenue ermitteln und diese in ziemlich }
  105.   { mutierter Form wieder gemeinsam in einem Langwort ablegen: }
  106.   men := item AND $1F;
  107.   menitem := (item SHR 5) AND $3F;
  108.   subitem := (item SHR 11) AND $1F;
  109.   menucode := (Long(men+1) SHL 16) OR ((menitem+1) SHL 8) OR (subitem+1);
  110.   item_address := ItemAddress(Strip,item);
  111.   nextselect := item_address^.NextSelect;
  112. END;
  113. BEGIN
  114.   IF nextselect<>MENUNULL THEN BEGIN
  115.     menu_eval(nextselect); Exit;
  116.   END;
  117.   Msg := Get_Msg(MyWindow^.UserPort);
  118.   IF Msg<>Nil THEN BEGIN
  119.     CASE Msg^.class OF
  120.       MENUPICK: IF Msg^.Code<>MENUNULL THEN menu_eval(Msg^.Code);
  121.       MOUSEBUTTONS: IF Msg^.Code=SELECTDOWN THEN BEGIN
  122.           newevent := True; mouseclicked := True;
  123.           charx := MyWindow^.RPort^.TxWidth;
  124.           chary := MyWindow^.RPort^.TxHeight;
  125.           clickedx := 1 + (Msg^.MouseX - MyWindow^.BorderLeft) DIV charx;
  126.           clickedy := 1 + (Msg^.MouseY - MyWindow^.BorderTop) DIV chary;
  127.           dblclicked := DoubleClick(lastmsg.seconds,lastmsg.micros,
  128.               Msg^.seconds,Msg^.micros);
  129.           lastmsg := Msg^;
  130.         END;
  131.       RAWKEY: IF Msg^.Code<$80 THEN BEGIN { losgelassene Tasten ignorieren }
  132.           inpev.ie_Code := Msg^.Code;
  133.           inpev.ie_Qualifier := Msg^.Qualifier;
  134.           pp := Msg^.IAddress;
  135.           inpev.ie_position.ie_addr := pp^;
  136.           IF RawKeyConvert(^inpev,^buf,10,Nil)>0 THEN BEGIN
  137.             taste := buf[1];
  138.             newevent := True;
  139.           END;
  140.           rawcode := Msg^.Qualifier OR (Long(Msg^.Code) SHL 16);
  141.         END;
  142.       {
  143.       RAWKEY: IF Msg^.Code<$60 THEN BEGIN { "echte" Taste gedrückt }
  144.           taste := #155; { naja, irgendwie muß man das ja melden ... }
  145.           rawcode := Msg^.Qualifier OR (Long(Msg^.Code) SHL 16);
  146.           newevent := True;
  147.         END;
  148.       VANILLAKEY: BEGIN
  149.           taste := Chr(Msg^.Code); rawcode := Msg^.Qualifier;
  150.           newevent := True;
  151.         END;
  152.       }
  153.       OTHERWISE;
  154.     END;
  155.     Reply_Msg(Msg);
  156.   END;
  157. END;
  158.  
  159. PROCEDURE check{(code: Long; really: Boolean)};
  160. { Menuehäkchen setzen/löschen }
  161. VAR it: p_MenuItem;
  162.     m,i,s: Integer;
  163.     syscode: Word;
  164. BEGIN
  165.   m := (code SHR 16) - 1;
  166.   i := ((code SHR 8) AND $FF) - 1;
  167.   s := (code AND $FF) - 1;
  168.   syscode := m OR (i SHL 5) OR (s SHL 11);
  169.   it := ItemAddress(Strip,syscode);
  170.   IF it=Nil THEN Exit;
  171.   IF really THEN
  172.     it^.Flags := it^.Flags OR CHECKED
  173.   ELSE
  174.     it^.Flags := it^.Flags AND NOT CHECKED;
  175. END;
  176.  
  177. FUNCTION has_check{(code: Long): Boolean};
  178. { Menuehäkchen abfragen }
  179. VAR it: p_MenuItem;
  180.     m,i,s: Integer;
  181.     syscode: Word;
  182. BEGIN
  183.   m := (code SHR 16) - 1;
  184.   i := ((code SHR 8) AND $FF) - 1;
  185.   s := (code AND $FF) - 1;
  186.   syscode := m OR (i SHL 5) OR (s SHL 11);
  187.   it := ItemAddress(Strip,syscode);
  188.   IF it<>Nil THEN
  189.     has_check := (it^.Flags AND CHECKED)<>0;
  190. END;
  191.  
  192. FUNCTION ja_nein{(message: Str): Boolean};
  193. CONST charx=8; chary=8;
  194. BEGIN
  195.   ITxt[1] := IntuiText(2,1,JAM1,10,10,Nil,message,Nil);
  196.   ITxt[2] := IntuiText(2,1,JAM1,6,3,Nil,'  JA  ',Nil);
  197.   ITxt[3] := IntuiText(2,1,JAM1,6,3,Nil,' NEIN ',Nil);
  198.   ja_nein := AutoRequest(MyWindow,^ITxt[1],^ITxt[2],^ITxt[3],0,0,
  199.           (6+Length(message))*charx,3*(chary+2)+30);
  200. END;
  201.  
  202. PROCEDURE create_icon{(VAR src,dest: Str80)};
  203. VAR icon: p_DiskObject;
  204. BEGIN
  205.   IF (IconBase<>Nil) AND (src<>'') THEN BEGIN
  206.     icon := GetDiskObject(src);
  207.     IF icon<>Nil THEN BEGIN
  208.       icon^.do_CurrentX := NO_ICON_POSITION;
  209.       icon^.do_CurrentY := NO_ICON_POSITION;
  210.       icon^.do_Type := WBPROJECT;
  211.       IF NOT PutDiskObject(dest,icon) THEN;
  212.       FreeDiskObject(icon);
  213.     END;
  214.   END;
  215. END;
  216.  
  217. FUNCTION fileselect{(was_los: str80; speichern: Boolean;
  218.                                    VAR selected: str80): Boolean};
  219. { Benutzt, wenn vorhanden, den Filerequester der asl.library, }
  220. { sonst den aus der req.library, und notfalls ein Stringgadget. }
  221. VAR i,p,l: Integer;
  222.     Req: p_FileRequester;
  223.     Msg: p_IntuiMessage;
  224.     ende: Boolean;
  225.     class: Long;
  226.     b,h: Word;
  227.     buf,ubuf: str80;
  228.     muell: ARRAY[0..31] OF Byte;
  229. BEGIN
  230.   fileselect := False;
  231.   l := Length(selected);
  232.   { selected in pfad und name spalten }
  233.   p := 0; FOR i := 1 TO l DO
  234.     IF selected[i] IN ['/',':'] THEN p := i;
  235.   IF p=0 THEN pfad := '' ELSE pfad := Copy(selected,1,p);
  236.   IF p=l THEN name := '' ELSE name := Copy(selected,p+1,l-p);
  237.   IF AslBase<>Nil THEN BEGIN            { *** "asl.library" benutzen }
  238.     Tags[1] := TagItem(ASL_Hail,Long(^was_los));
  239.     Tags[2] := TagItem(ASL_Dir,Long(^pfad));
  240.     Tags[3] := TagItem(ASL_File,Long(^name));
  241.     Tags[4] := TagItem(ASL_Window,Long(MyWindow));
  242.     Tags[5] := TagItem(ASL_FuncFlags,FILF_SAVE);
  243.     i := 5; IF speichern THEN Inc(i);
  244.     Tags[i] := TagItem(TAG_DONE,0);
  245.     Req := AllocAslRequest(ASL_FileRequest,^Tags);
  246.     IF Req<>NIL THEN BEGIN
  247.       IF RequestFile(Req) THEN
  248.         IF Req^.rf_File<>'' THEN BEGIN
  249.           fileselect := True;
  250.           pfad := Req^.rf_Dir; l := Length(pfad);
  251.           name := Req^.rf_File;
  252.           IF l=0 THEN
  253.             selected := name
  254.           ELSE IF pfad[l-1] IN [':','/'] THEN
  255.             selected := pfad+name
  256.           ELSE
  257.             selected := pfad+'/'+name;
  258.         END;
  259.       FreeAslRequest(Req);
  260.     END;
  261.   END ELSE IF ReqBase<>Nil THEN BEGIN  { *** "req.library" benutzen }
  262.     WITH MyFileReq^ DO BEGIN
  263.       VersionNumber := REQVERSION;
  264.       Title := was_los;
  265.       PathName := pfadname;   { Str-Zeiger auf meinen Puffer setzen }
  266.       Dir := pfad;
  267.       _File := name;
  268.       WindowLeftEdge := 128;
  269.       WindowTopEdge := 25;
  270.       Flags := FRQABSOLUTEXYM;
  271.       IF speichern THEN
  272.         Flags := Flags OR FRQSAVINGM
  273.       ELSE
  274.         Flags := Flags OR FRQLOADINGM;
  275.       { dran denken, Hintergrund türkis }
  276.       filenamescolor := 1;    { schwarz }
  277.       dirnamescolor := 2;     { weiß }
  278.       devicenamescolor := 1;  { schwarz }
  279.       detailcolor := 6;       { grün }
  280.       blockcolor := 1;        { schwarz }
  281.       gadgettextcolor := 1;   { schwarz }
  282.       stringgadgetcolor := 1; { schwarz }
  283.       textmessagecolor := 7;  { gelb }
  284.       stringnamecolor := 7;   { gelb }
  285.       boxbordercolor := 5;    { blau }
  286.       gadgetboxcolor := 5;    { blau }
  287.     END;
  288.     IF _FileRequester(MyFileReq) THEN BEGIN
  289.       fileselect := True;
  290.       selected := pfadname;
  291.     END;
  292.   END ELSE BEGIN  { *** einfacher Requester mit Stringgadget }
  293.     buf := selected; ubuf := '';
  294.     b := 8*50 + 30;  IF Length(was_los)>50  THEN b := 8*Length(was_los) + 30;
  295.     h := 9 + 8 + 20;
  296.     ITxt[1] := IntuiText(1,3,JAM1,15,6,Nil,was_los,Nil);
  297.     TextBordXY := IntArr10(-1,8,400,8,400,-1,-1,-1,-1,8);
  298.     Borders[1] := Border(0,0,2,0,JAM1,3,^TextBordXY,^Borders[2]);
  299.     Borders[2] := Border(0,0,1,0,JAM1,3,^TextBordXY[5],Nil);
  300.     TextInfo := StringInfo(^buf,^ubuf,0,79,0,0,0,0,0,0,Nil,0,Nil);
  301.     TextGad := Gadget(Nil,(b-8*50) DIV 2,9+12,8*50,8,GADGHCOMP,
  302.       RELVERIFY OR ENDGADGET, STRGADGET OR REQGADGET,
  303.       ^Borders[1], Nil,Nil,0,^TextInfo,2,Nil);
  304.     MainBordXY := IntArr10(0,h-1,b-1,h-1,b-1,0,0,0,0,h-1);
  305.     Borders[3] := Border(0,0,1,0,JAM1,3,^MainBordXY,^Borders[4]);
  306.     Borders[4] := Border(0,0,2,0,JAM1,3,^MainBordXY[5],Nil);
  307.     MyRequest := Requester(Nil,70,90,b,h,0,0,^TextGad,^Borders[3],
  308.         ^ITxt[1],0,(colperm SHR 12) AND $F,Nil,muell,Nil,Nil,Nil,muell);
  309.     IF Request(^MyRequest,MyWindow) THEN BEGIN { Ereignisse abfragen }
  310.       ende := False;
  311.       REPEAT
  312.         REPEAT              { Schleife, da mehrere Ereignisse möglich }
  313.           Msg := Get_Msg(MyWindow^.UserPort);
  314.           IF Msg<>Nil THEN BEGIN
  315.             class := Msg^.Class;
  316.             Reply_Msg(Msg);             { so schnell wie möglich antworten! }
  317.             IF class=REQSET THEN
  318.               IF NOT ActivateGadget(^TextGad,MyWindow,^MyRequest) THEN;
  319.             IF class=REQCLEAR THEN ende := True;
  320.           END;
  321.         UNTIL Msg=Nil;
  322.         IF NOT ende THEN class := Wait(-1);
  323.       UNTIL ende;
  324.       IF buf<>'' THEN BEGIN
  325.         fileselect := True;
  326.         selected := buf;
  327.       END;
  328.     END;
  329.   END;
  330. END;
  331.  
  332. PROCEDURE scroll_text{(zl0,zl1, sp0,sp1, dy,dx: Integer)};
  333. { einen Textblock verschieben, benutzt natürlich ScrollRaster() }
  334. { Zeilen und Spalten werden, wie bei GotoXY üblich, ab 1 gezählt! }
  335. VAR charx,chary,i,x0,y0,x1,y1: Integer;
  336. BEGIN
  337.   charx := MyWindow^.RPort^.TxWidth;
  338.   chary := MyWindow^.RPort^.TxHeight;
  339.   dx := dx*charx; dy := dy*chary;
  340.   x0 := (sp0-1)*charx; x1 := sp1*charx-1;
  341.   y0 := (zl0-1)*chary; y1 := zl1*chary-1;
  342.   ScrollRaster(MyWindow^.RPort,dx,dy,x0,y0,x1,y1);
  343. END;
  344.  
  345. FUNCTION bitmapzeile{(plane,line: Integer): Ptr};
  346. VAR map: p_BitMap;
  347.     y0: Integer;
  348. BEGIN
  349.   map := MyWindow^.RPort^.BitMap;
  350.   y0 := MyWindow^.TopEdge + MyWindow^.BorderTop;
  351.   bitmapzeile := Ptr(Long(map^.Planes[plane]) + (y0+line)*map^.BytesPerRow);
  352. END;
  353.  
  354. PROCEDURE busy_pointer;
  355. BEGIN
  356.   IF BusyPointerData<>Nil THEN
  357.     SetPointer(MyWindow, BusyPointerData, 16, 16, -6, 0);
  358. END;
  359.  
  360. PROCEDURE normal_pointer;
  361. BEGIN
  362.   ClearPointer(MyWindow);
  363. END;
  364.  
  365. PROCEDURE showscreen{(mine: Boolean)};
  366. BEGIN
  367.   IF mine THEN BEGIN
  368.     ScreenToFront(MyScreen);
  369.     IF ActivateWindow(MyWindow)<>0 THEN { %-| };
  370.   END ELSE
  371.     IF NOT WBenchToFront THEN { Workbench gar nicht offen, na toll };
  372. END;
  373.  
  374. PROCEDURE getpalette;
  375. VAR i: Integer;
  376. BEGIN
  377.   FOR i := 0 TO 7 DO
  378.     palette[i] := GetRGB4(MyScreen^.ViewPort.ColorMap,
  379.       (colperm SHR (4*(7-i))) AND $F);
  380. END;
  381.  
  382. PROCEDURE telltime{(VAR day,min,tic: Long)};
  383. VAR time: DateStamp;
  384. BEGIN
  385.   IF _DateStamp(^time)<>Nil THEN BEGIN
  386.     day := time.ds_Days;
  387.     min := time.ds_Minute;
  388.     tic := time.ds_Tick;
  389.   END;
  390. END;
  391.  
  392. { ## Dies sind *nicht* die Original-Funktionen aus dem Unit ExecSupport! }
  393. { ## Für meine Zwecke sind sie aber gut genug: }
  394.  
  395. FUNCTION CreatePort (name: Str; pri: Byte) : p_MsgPort;
  396. VAR port   : p_MsgPort;
  397.     sigbit : Byte;
  398. BEGIN
  399.   port := Ptr (Alloc_Mem (SizeOf(MsgPort), MEMF_CLEAR or MEMF_PUBLIC ));
  400.   sigbit := AllocSignal(-1);
  401.   IF sigbit <> -1 THEN
  402.     WITH port^, mp_Node DO BEGIN
  403.       ln_Name := name;
  404.       ln_Pri := pri;
  405.       ln_Type := NT_MSGPORT;
  406.       mp_Flags := PA_SIGNAL;
  407.       mp_SigBit := sigbit;
  408.       mp_SigTask := FindTask(Nil);
  409.       AddPort (port);
  410.     END;
  411.   CreatePort := port;
  412. END;
  413.  
  414. PROCEDURE DeletePort (port: p_MsgPort);
  415. BEGIN
  416.   RemPort (port);
  417.   port^.mp_Node.ln_Type := $FF;
  418.   port^.mp_MsgList.lh_head := Ptr(-1);
  419.   FreeSignal (port^.mp_SigBit);
  420.   Free_Mem (Long(port), SizeOf (port^) )
  421. END;
  422.  
  423. FUNCTION CreateExtIO (ioReplyPort: p_MsgPort; size: Long) : Ptr;
  424. VAR ioReq: p_IORequest;
  425. BEGIN
  426.   IF ioReplyPort=Nil THEN
  427.     CreateExtIO := Nil
  428.   ELSE BEGIN
  429.     ioReq := Ptr (Alloc_Mem (size, MEMF_CLEAR or MEMF_PUBLIC));
  430.     WITH ioReq^, io_Message DO BEGIN
  431.       mn_Node.ln_Type := NT_MESSAGE;
  432.       mn_Length := size;
  433.       mn_ReplyPort := ioReplyPort;
  434.     END;
  435.     CreateExtIO := ioReq;
  436.   END;
  437. END;
  438.  
  439. PROCEDURE DeleteExtIO (ioExt: Ptr);
  440. VAR io: p_IoRequest;
  441. BEGIN
  442.   io := ioExt;
  443.   IF io <> Nil THEN
  444.     WITH io^ DO BEGIN
  445.       io_Message.mn_Node.ln_Type := $FF;
  446.       io_Device := Ptr(-1);
  447.       io_Unit := Ptr(-1);
  448.       Free_Mem (Long (ioExt), io^.io_Message.mn_Length)
  449.     END;
  450. END;
  451.  
  452. { ## Ende der nachgemachten ExecSupport-Funktionen }
  453.  
  454. PROCEDURE force_time{(VAR s: Str80)};
  455. { setzt die Systemzeit (Tageszeit), Datum bleibt unverändert }
  456. VAR port: ^MsgPort;
  457.     t_ioreq: ^TimeRequest;
  458.     err: Integer;
  459.     secs,w: Long;
  460.     i,j: Integer;
  461. CONST spd=60*60*24;
  462. BEGIN
  463.   { Uhrzeit-String "09:12:35", "912/35" o. ä. in Sekunden umrechnen }
  464.   secs := 0; j := 0; w := 1; { w: Wert der Ziffer }
  465.   FOR i := Length(s) DOWNTO 1 DO BEGIN
  466.     IF s[i] IN ['0'..'9'] THEN BEGIN
  467.       secs := secs + w*(Ord(s[i])-48);
  468.       Inc(j);
  469.       CASE j OF
  470.         1,3,5: w := 10*w;
  471.         2,4: w := 6*w;
  472.         OTHERWISE w := 0;
  473.       END;
  474.     END;
  475.   END;
  476.   IF j<5 THEN Exit; { das kann keine Uhrzeit gewesen sein }
  477.   { der ganze device-Ärger: }
  478.   port := CreatePort('VT-timer',0);
  479.   t_ioreq := CreateExtIO(port,SizeOf(TimeRequest));
  480.   IF OpenDevice('timer.device',UNIT_VBLANK,Ptr(t_ioreq),0)=0 THEN BEGIN
  481.     { Uhrzeit erst lesen: }
  482.     t_ioreq^.tr_node.io_Command := TR_GETSYSTIME;
  483.     err := DoIO(Ptr(t_ioreq));
  484.     { Tageszeit ändern und neu setzten: }
  485.     t_ioreq^.tr_node.io_Command := TR_SETSYSTIME;
  486.     WITH t_ioreq^.tr_time DO BEGIN
  487.       tv_secs := (tv_secs DIV spd)*spd + secs; tv_micro := 0;
  488.     END;
  489.     err := DoIO(Ptr(t_ioreq));
  490.     { Und tschüss: }
  491.     CloseDevice(Ptr(t_ioreq));
  492.   END;
  493.   DeleteExtIO(t_ioreq);
  494.   DeletePort(port);
  495. END;
  496.  
  497. PROCEDURE clip_it{(s: Str; len: Long)};
  498. { String ins Clipboard schreiben }
  499. VAR err: Integer;
  500. BEGIN
  501.   IF clip_open THEN BEGIN
  502.     clipreq^.io_Command := CMD_WRITE;
  503.     clipreq^.io_Data := s;
  504.     clipreq^.io_Length := len;
  505.     err := DoIO(Ptr(clipreq));
  506.   END;
  507. END;
  508.  
  509. PROCEDURE start_clip{(size: Long)};
  510. BEGIN
  511.   IF clip_open THEN Exit;
  512.   clip_port := CreatePort('clipper',0);
  513.   clipreq := CreateExtIO(clip_port,SizeOf(IOClipReq));
  514.   IF OpenDevice('clipboard.device',PRIMARY_CLIP,Ptr(clipreq),0)=0 THEN BEGIN
  515.     clipreq^.io_Offset := 0;
  516.     clipreq^.io_ClipID := 0;
  517.     clip_open := True;
  518.     clip_it('FORM',4); { IFF-Header }
  519.     size := size + 12; clip_it(Ptr(^size),4); size := size - 12;
  520.     clip_it('FTXTCHRS',8);
  521.     clip_it(Ptr(^size),4);
  522.   END ELSE BEGIN
  523.     DeleteExtIO(clipreq);
  524.     DeletePort(clip_port);
  525.   END;
  526. END;
  527.  
  528. PROCEDURE end_clip;
  529. VAR err: Integer;
  530. BEGIN
  531.   IF clip_open THEN BEGIN
  532.     { melden, daß man fertig ist }
  533.     clipreq^.io_Command := CMD_UPDATE;
  534.     err := DoIO(Ptr(clipreq));
  535.     { Und tschüss: }
  536.     CloseDevice(Ptr(clipreq));
  537.     DeleteExtIO(clipreq);
  538.     DeletePort(clip_port);
  539.     clip_open := False;
  540.   END;
  541. END;
  542.  
  543. { *** mein Menü: }
  544.  
  545. PROCEDURE create_menu;
  546. CONST Check = CHECKIT OR MENUTOGGLE;
  547.       CheckOn = Check OR CHECKED;
  548. VAR egal: Boolean;
  549. BEGIN
  550.   LastMenu := Nil;
  551.   AddMenu(10, 'Projekt');
  552.     AddItem(0, 0, 'Info',               '?');
  553.     AddItem(0, 0, 'Hilfe        Help',  ' ');
  554.     AddItem(0, 0, 'Parameter sichern',  ' ');
  555.     AddItem(5, 0, 'Ende',               'Q');
  556.   AddMenu(20, 'Datei');
  557.     AddItem(0, 0, 'VT-Format laden',              'L');
  558.     AddItem(5, 0, 'Ausgabeformat  »',             ' ');
  559.       AddSubItem(0, Check,  '  ASCII',            'A'); MutEx(%10);
  560.       AddSubItem(0, CheckOn,'  VT',               'V'); MutEx(%01);
  561.     AddItem(0, CheckOn, '  Überschreiben',        'M');
  562.     AddItem(5, 0, 'Dateinamen  »',                ' ');
  563.       AddSubItem(0, 0, 'ändern ...',              'N');
  564.       AddSubItem(0, 0, 'nach Titelzeile  Ctrl-N', ' ');
  565.     AddItem(0, Check, '  Icons erzeugen      I',  ' ');
  566.     AddItem(0, Check, '  numerierte Dateien  #',  ' ');
  567.   AddMenu(20, 'Seiten');
  568.     AddItem(0, 0, 'Zurückgehen        Esc',          ' ');
  569.     AddItem(5, 0, 'Textausdruck',                    'P');
  570.     AddItem(0 ,0, 'IFF-Bild ...',                    'I');
  571.     AddItem(0, 0, 'Seite speichern  »',              ' ');
  572.       AddSubItem(0, 0, 'nur diese                 S',' ');
  573.       AddSubItem(0, 0, 'mit allen Unterseiten',      'S');
  574.       AddSubItem(0, 0, 'alle Seiten          Ctrl-S',' ');
  575.     AddItem(5, 0, 'Seite löschen  »',                ' ');
  576.       AddSubItem(0, 0, 'nur diese                 Del',' ');
  577.       AddSubItem(0, 0, 'mit a. Unterseiten  Shift-Del',' ');
  578.       AddSubItem(0, 0, 'alle Seiten          Ctrl-Del',' ');
  579.   AddMenu(20, 'Anfordern');
  580.     AddItem(0, 0, 'Seite 100',                  '0');
  581.     AddItem(0, 0, 'diese Seite nochmal    f8',  ' ');
  582.     AddItem(0, 0, '1. Vorauswahl         f10',  ' ');
  583.     AddItem(0, 0, '2. Vorauswahl         F10',  ' ');
  584.     AddItem(0, 0, 'Stichprobe             f6',  ' ');
  585.     AddItem(5, 0, 'Vorauswahl editieren  »',    ' ');
  586.       AddSubItem(0, 0, 'erste   f9',            ' ');
  587.       AddSubItem(0, 0, 'zweite  F9',            ' ');
  588.     AddItem(0, 0, 'Seitennrn. kopieren',        '#');
  589.     AddItem(5, 0, 'TOP-Verzeichnis  »',         ' ');
  590.       AddSubItem(0, 0, 'erstellen  f5',         ' ');
  591.       AddSubItem(0, 0, 'löschen    F5',         ' ');
  592.     AddItem(0, 0, 'TOP-Statistik          f4',  ' ');
  593.     AddItem(0, 0, 'Blockseiten holen      F4',  ' ');
  594.     AddItem(5, 0, 'Seitensuche löschen    f7',  ' ');
  595.     AddItem(0, 0, 'einen Job löschen      F7',  ' ');
  596.     AddItem(0, CheckOn, '  FIFO',               'F');
  597.   AddMenu(20, 'Extras');
  598.     AddItem(0, 0,     'Rätseltaste             ?', ' ');
  599.     AddItem(0, 0,     'Seite neu aufbauen  Space', ' ');
  600.     AddItem(5, 0,     'Sendernamen zeigen      N', ' ');
  601.     AddItem(0, Check, '  Test/Uhr              T', ' ');
  602.     AddItem(0, 0,     'Uhrzeit übernehmen',        'T');
  603.     AddItem(5, 0,     'Fernsehdarstellung  »',     ' ');
  604.       AddSubItem(0, CheckOn, '  ein',              ' '); MutEx(%110);
  605.       AddSubItem(0, Check,   '  transparent',      ' '); MutEx(%101);
  606.       AddSubItem(0, Check,   '  aus',              ' '); MutEx(%011);
  607.     AddItem(0, 0,     'Decoder-Reset          F8', ' ');
  608.   MenuWidths;
  609.   egal := SetMenuStrip(MyWindow,Strip);
  610. END;
  611.  
  612. PROCEDURE sysinit{(version: Str)};
  613. VAR i,breite,hoehe: Integer;
  614.     egal: Long;
  615.     Con2: ^ConsoleHandle;
  616. BEGIN
  617.   titel := copy(version,7,length(version)-6);
  618.   { Zuerst Zeiger für den zugehörigen ExitServer initialisieren: }
  619.   IntuitionBase := Nil; GfxBase := Nil; DiskFontBase := Nil;
  620.   IconBase := Nil; ReqBase := Nil; AslBase := Nil;
  621.   MyScreen := Nil; MyWindow := Nil; Strip := Nil; teleFont := Nil;
  622.   myprocess := Nil; BusyPointerData := Nil; MyFileReq := Nil;
  623.   { Filerequester-Struktur anlegen, muß mit Nullen vorbesetzt sein! }
  624.   MyFileReq := Ptr(AllocMem(SizeOf(ReqFileRequester),MEMF_CLEAR));
  625.   IF MyFileReq=Nil THEN Error('Out of memory!');
  626.   { Libraries etc. öffnen: }
  627.   IntuitionBase := OpenLibrary('intuition.library',0);
  628.   GfxBase := OpenLibrary(GRAPHICSNAME,0);
  629.   DiskFontBase := OpenLibrary('diskfont.library',0);
  630.   IconBase := OpenLibrary('icon.library',0);
  631.   AslBase := OpenLibrary(ASLNAME,0);
  632.   IF AslBase=Nil THEN ReqBase := OpenLibrary('req.library',0);
  633.   IF IntuitionBase=Nil THEN Error('Can''t open intuition.library!');
  634.   IF GfxBase=Nil THEN Error('Can''t open graphics.library!');
  635.   IF DiskfontBase=Nil THEN desaster('Can''t open diskfont.library !!!');
  636.   { Screen: }
  637.   breite := 640; hoehe := 256;
  638.   topazAttr := TextAttr('topaz.font',8,FS_NORMAL,FPF_ROMFONT);
  639.   { Verwendung der Default-Pens für den Screen erzwingen: }
  640.   i := -1;
  641.   Tags[1] := TagItem(SA_Pens,Long(^i));
  642.   Tags[2] := TagItem(TAG_DONE,0);
  643.   NeuerScreen := ExtNewScreen(0,0,breite,hoehe,3,0,1,HIRES,
  644.     NS_EXTENDED OR CUSTOMSCREEN,^topazAttr,titel,Nil,Nil,^Tags[1]);
  645.   MyScreen := OpenScreen(^NeuerScreen);
  646.   IF MyScreen=Nil THEN Error('Can''t open screen!');
  647.   FOR i := 0 TO 7 DO
  648.     SetRGB4(^MyScreen^.ViewPort, (colperm SHR (4*(7-i))) AND $F,
  649.       (palette[i] SHR 8) AND $F,(palette[i] SHR 4) AND $F,(palette[i]) AND $F);
  650.   { Fenster und Menue: }
  651.   i := MyScreen^.BarHeight + 5;
  652.   NeuesWindow := NewWindow(0,i,breite,hoehe-i,0,1,
  653.         MENUPICK OR MOUSEBUTTONS OR REQCLEAR OR REQSET OR RAWKEY,
  654.         ACTIVATE OR BORDERLESS OR BACKDROP,Nil,Nil, Nil,
  655.         MyScreen,Nil,170,100,breite,hoehe,CUSTOMSCREEN);
  656.   MyWindow := OpenWindow(^NeuesWindow);                          
  657.   IF MyWindow=Nil THEN Error('Can''t open window!');
  658.   create_menu;
  659.   { Font: }
  660.   teleAttr := TextAttr('videotext.font',9,FS_NORMAL,FPF_DISKFONT);
  661.   IF DiskFontBase<>Nil THEN
  662.     teleFont := OpenDiskFont(^teleAttr);
  663.   IF teleFont<>Nil THEN
  664.     egal := SetFont(MyWindow^.RPort,teleFont)
  665.   ELSE
  666.     desaster('Can''t open videotext.font !!!');
  667.   { Console einrichten: }
  668.   Con := OpenConsole(MyWindow); SetStdIO(Con);
  669.   Con2 := Con; ConsoleDevice := Con2^.ReadIO.io_Device;
  670.   BusyPointerData := Ptr(AllocMem(SizeOf(WordArr36),MEMF_CHIP));
  671.   IF BusyPointerData<>Nil THEN
  672.     BusyPointerData^ := WordArr36(
  673.       $0000,$0000,
  674.       $0400,$07C0,$0000,$07C0,$0100,$0380,$0000,$07E0,
  675.       $07C0,$1FF8,$1FF0,$3FEC,$3FF8,$7FDE,$3FF8,$7FBE,
  676.       $7FFC,$FF7F,$7EFC,$FFFF,$7FFC,$FFFF,$3FF8,$7FFE,
  677.       $3FF8,$7FFE,$1FF0,$3FFC,$07C0,$1FF8,$0000,$07E0,
  678.       $0000,$0000
  679.     );
  680.   { meine Task finden und System Requests auf meinen Screen umleiten }
  681.   myprocess := Ptr(FindTask(Nil));
  682.   IF myprocess<>Nil THEN BEGIN
  683.     oldwindowptr := myprocess^.pr_WindowPtr;
  684.     myprocess^.pr_WindowPtr := MyWindow;
  685.   END;
  686. END;
  687.  
  688. PROCEDURE sysclean;
  689. BEGIN
  690.   IF myprocess<>Nil THEN
  691.     myprocess^.pr_WindowPtr := oldwindowptr;
  692.   IF ReqBase<>Nil THEN BEGIN
  693.     PurgeFiles(MyFileReq); CloseLibrary(ReqBase); END;
  694.   IF MyFileReq<>Nil THEN FreeMem(MyFileReq,SizeOf(ReqFileRequester));
  695.   IF MyWindow<>Nil THEN BEGIN
  696.     IF Strip<>Nil THEN ClearMenuStrip(MyWindow); TrashMenu;
  697.     CloseWindow(MyWindow);
  698.   END;
  699.   IF MyScreen<>Nil THEN IF CloseScreen(MyScreen) THEN;
  700.   IF teleFont<>Nil THEN CloseFont(teleFont);
  701.   IF BusyPointerData<>Nil THEN FreeMem(BusyPointerData,SizeOf(WordArr36));
  702.   IF IntuitionBase<>Nil THEN CloseLibrary(IntuitionBase);
  703.   IF GfxBase<>Nil THEN CloseLibrary(GfxBase);
  704.   IF DiskFontBase<>Nil THEN CloseLibrary(DiskFontBase);
  705.   IF IconBase<>Nil THEN CloseLibrary(IconBase);
  706.   IF AslBase<>Nil THEN CloseLibrary(AslBase);
  707.   { festhalten, daß alles geschlossen ist: }
  708.   ReqBase := Nil; MyFileReq := Nil;
  709.   Strip := Nil; MyWindow := Nil; MyScreen := Nil;
  710.   teleFont := Nil;
  711.   BusyPointerData := Nil;
  712.   IntuitionBase := Nil;
  713.   GfxBase := Nil;
  714.   DiskFontBase := Nil;
  715.   IconBase := Nil;
  716.   AslBase := Nil;
  717. END;
  718.  
  719. BEGIN  { Initialisierungsteil }
  720.   { RGB-Anteile der Farben in der Reihenfolge sw,rt,gn,gb,bl,vl,cn,ws: }
  721.   palette[0] := $000; palette[1] := $F00; palette[2] := $0F0;
  722.   palette[3] := $FF0; palette[4] := $00F; palette[5] := $F0F;
  723.   palette[6] := $0FF; palette[7] := $FFF;
  724.   colperm := $01234567;
  725.   clip_open := False;
  726.   lastmsg.seconds := 0; nextselect := MENUNULL;
  727.   newevent := False; mouseclicked := False; menupicked := False; taste := #0;
  728.   inpev.ie_NextEvent := Nil;
  729.   inpev.ie_Class := IECLASS_RAWKEY;
  730.   inpev.ie_SubClass := 0;
  731. END.
  732.  
  733.