home *** CD-ROM | disk | FTP | other *** search
/ The Best of Mecomp Multimedia 1 / Mecomp-CD.iso / amiga / tools / misc / videotext5.41 / src / sys.p < prev    next >
Encoding:
Text File  |  1997-06-15  |  39.5 KB  |  1,116 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.     rexxzeile: String[256];
  14.     palette: ARRAY[0..7] OF Word;
  15.     colperm: Long;
  16.     screenmode: Long;
  17.     pubsname, portname: String[10];    { z. B. "WNVT0" }
  18.     fontno: Integer;  { 1 oder 2, entspricht videotext/9 und /15 }
  19.     datestyle: Byte;  { 0..3 }
  20.     scriptnames: ARRAY[1..10] OF String[32];  { erscheinen im Menue }
  21.     rxscripts: Integer;   { 0..10 }
  22.     rexxpath: String[20];
  23.     silentrexx: Boolean;  { Skripts unauffällig auf der Workbench? }
  24.     Con: Ptr;  { darf nicht vom ExitServer geschlossen werden, komisch }
  25.  
  26. PROCEDURE event_scan(rexx_too: Boolean);
  27. PROCEDURE rexxreply(x: Long; s: Str);
  28. FUNCTION rexxecute(i: Integer): Boolean;
  29. PROCEDURE scriptscan;
  30. PROCEDURE ghostme(code: Long; really: Boolean);
  31. PROCEDURE checkme(code: Long; really: Boolean);
  32. FUNCTION has_check(code: Long): Boolean;
  33. FUNCTION ja_nein(message: Str): Boolean;
  34. FUNCTION ask_and_kill(name: Str; ask: Boolean): Boolean;
  35. FUNCTION stringrequest(meldung: str80; VAR eingabe: str80): Boolean;
  36. FUNCTION fileselect(was_los: str80; speichern: Boolean;
  37.                                    VAR selected: str80): Boolean;
  38. PROCEDURE create_icon(src, dest: Str);
  39. PROCEDURE append_datestr(VAR s: str80; smart: Boolean);
  40. PROCEDURE desaster(meldung: str80);
  41. PROCEDURE stretch_line(zeile, sp0, sp1: Integer);
  42. PROCEDURE raster_line(zeile, sp0, sp1: Integer; farbe: Word);
  43. PROCEDURE scroll_text(zl0,zl1, sp0,sp1, dy,dx: Integer);
  44. FUNCTION newfontno: Boolean;
  45. FUNCTION iffdump(VAR filename: str80; withicon: Boolean): Boolean;
  46. PROCEDURE busy_pointer;             
  47. PROCEDURE normal_pointer;
  48. PROCEDURE showscreen(which: Integer);
  49. PROCEDURE getpalette;              
  50. PROCEDURE telltime(VAR day,min,tic: Long);
  51. PROCEDURE force_time(VAR s: Str80);
  52. PROCEDURE start_clip(size: Long);
  53. PROCEDURE clip_it(s: Str; len: Long);
  54. PROCEDURE end_clip;
  55. PROCEDURE sysinit(version: Str);
  56. FUNCTION privateer: Integer;
  57. PROCEDURE sysclean;         
  58.  
  59. { ---------------------------------------------------------------------- }
  60.  
  61. IMPLEMENTATION;
  62.  
  63. {$opt q,s+,i+ } { keine Laufzeitprüfungen außer Stack und Feldindizes }
  64. CONST INTUI_V36_NAMES_ONLY=1; { kein "intuition/iobsolete.h", bitte! }
  65. {$incl "intuition.lib", "gadtools.lib", "graphics.lib", "diskfont.lib" }
  66. {$incl "exec.lib", "dos.lib", "icon.lib", "asl.lib", "rexxsyslib.lib" }
  67. {$incl "exec/libraries.h", "devices/timer.h", "devices/clipboard.h" }
  68.  
  69. CONST anzmenu=99;
  70.  
  71. TYPE WordArr36 = ARRAY [1..36] OF Word;
  72.      NMArray = ARRAY [1..anzmenu] OF NewMenu;
  73.  
  74. VAR strstack: String[2000]; STATIC;
  75.     Tags: Array[1..10] OF TagItem;  STATIC;
  76.     TheMenu: NMArray;  STATIC;
  77.     BusyPointerData: ^WordArr36;
  78.     titel: Str80;  STATIC;
  79.     myprocess: p_Process;
  80.     MyScreen: p_Screen;
  81.     MyWindow,oldwindowptr: p_Window;
  82.     visinfo: Ptr;
  83.     Strip: p_Menu;
  84.     teleFont: p_TextFont;
  85.     nextselect: Word;
  86.     lastmsg: IntuiMessage; { kein Zeiger! }
  87.     rexxport,replyport: p_MsgPort;
  88.     rxm, scriptmess: p_RexxMsg;
  89.     fenster: Text;
  90.     { fürs clipboard.device: }
  91.     clip_port: ^MsgPort;
  92.     clipreq: ^IOClipReq; { erweiterte IO-Request-Struktur }
  93.     clip_open: Boolean;
  94.  
  95.  
  96. PROCEDURE event_scan{(rexx_too: Boolean)};
  97. { überträgt eingehende Tasten und ESC-Sequenzen sowie die Intuition- }
  98. { Ereignisse Mausklick und Menuewahl in globale Variablen. }
  99. VAR im: p_IntuiMessage;
  100.     i,charx,chary: Integer;
  101.     pp: ^Ptr;
  102.     buf: String[10];
  103. PROCEDURE menu_eval(item: Word);
  104. { wird an zwei Stellen gebraucht ... }
  105. VAR men,menitem,subitem: Word;
  106.     item_address: ^MenuItem;
  107. BEGIN
  108.   newevent := True; menupicked := True;
  109.   { Menue, Menuepunkt und Untermenue ermitteln und diese in ziemlich }
  110.   { mutierter Form wieder gemeinsam in einem Langwort ablegen: }
  111.   men := item AND $1F;
  112.   menitem := (item SHR 5) AND $3F;
  113.   subitem := (item SHR 11) AND $1F;
  114.   menucode := (Long(men+1) SHL 16) OR ((menitem+1) SHL 8) OR (subitem+1);
  115.   item_address := ItemAddress(Strip,item);
  116.   nextselect := item_address^.NextSelect;
  117. END;
  118. BEGIN
  119.   IF scriptmess<>Nil THEN       { ARexx-Skript gestartet }
  120.     IF GetMsg(replyport)<>Nil THEN BEGIN  { ... und ist gerade zu Ende }
  121.       Close(fenster);
  122.       DeleteArgstring(scriptmess^.rm_Args[0]);
  123.       DeleteRexxMsg(scriptmess); scriptmess := Nil;
  124.       FOR i := 1 TO rxscripts DO
  125.         ghostme($060300 + i*$100, False);
  126.     END;
  127.   IF nextselect<>MENUNULL THEN BEGIN
  128.     menu_eval(nextselect); Exit;
  129.   END;
  130.   im := p_IntuiMessage(GetMsg(MyWindow^.UserPort));
  131.   IF im<>Nil THEN BEGIN
  132.     CASE im^.class OF
  133.       IDCMP_MENUPICK: IF im^.Code<>MENUNULL THEN menu_eval(im^.Code);
  134.       IDCMP_MOUSEBUTTONS: IF im^.Code=SELECTDOWN THEN BEGIN
  135.           newevent := True; mouseclicked := True;
  136.           charx := MyWindow^.RPort^.TxWidth;
  137.           chary := MyWindow^.RPort^.TxHeight;
  138.           clickedx := 1 + (im^.MouseX - MyWindow^.BorderLeft) DIV charx;
  139.           clickedy := 1 + (im^.MouseY - MyWindow^.BorderTop) DIV chary;
  140.           dblclicked := DoubleClick(lastmsg.seconds,lastmsg.micros,
  141.               im^.seconds,im^.micros);
  142.           lastmsg := im^;
  143.         END;
  144.       IDCMP_RAWKEY: IF im^.Code<$60 THEN BEGIN { "echte" Taste gedrückt }
  145.           taste := #155; { naja, irgendwie muß man das ja melden ... }
  146.           rawcode := im^.Qualifier OR (Long(im^.Code) SHL 16);
  147.           newevent := True;
  148.         END;
  149.       IDCMP_VANILLAKEY: BEGIN
  150.           taste := Chr(im^.Code); rawcode := im^.Qualifier;
  151.           newevent := True;
  152.         END;
  153.       OTHERWISE;
  154.     END;
  155.     ReplyMsg(p_Message(im));
  156.   END;
  157.   IF newevent THEN Exit;
  158.   IF rexx_too AND (rexxport<>Nil) AND (rxm=Nil) THEN BEGIN
  159.     rxm := p_RexxMsg(GetMsg(rexxport));
  160.     IF rxm<>Nil THEN BEGIN
  161.       newevent := True;
  162.       rexxzeile := rxm^.rm_Args[0];
  163.     END;
  164.     { geantwortet wird später! }
  165.   END;
  166. END;
  167.  
  168. PROCEDURE rexxreply{(x: Long; s: Str)};
  169. { Returncode und evtl. Ergebnisstring zurückgeben }
  170. BEGIN
  171.   IF rxm<>Nil THEN BEGIN
  172.     rxm^.rm_Result1 := x;
  173.     IF (rxm^.rm_Action AND RXFF_RESULT<>0) AND (s<>'') THEN
  174.       rxm^.rm_Result2 := Long(CreateArgstring(s,Length(s)))
  175.     ELSE
  176.       rxm^.rm_Result2 := 0;
  177.     ReplyMsg(p_Message(rxm));
  178.     rxm := Nil; rexxzeile := '';
  179.   END;
  180. END;
  181.  
  182. FUNCTION rexxecute{(i: Integer): Boolean};
  183. { eins der 10 ARexx-Skripte starten, asynchron wohlgemerkt! }
  184. VAR s: String[200];
  185.     l: Long;
  186.     rxmp: p_MsgPort;
  187. BEGIN
  188.   rexxecute := False;
  189.   IF (i>rxscripts) OR (scriptmess<>Nil) THEN Exit;
  190.   s := rexxpath + scriptnames[i];
  191.   scriptmess := CreateRexxMsg(replyport, portname, Nil);
  192.   IF scriptmess=Nil THEN Exit;
  193.   scriptmess^.rm_Action := RXCOMM;
  194.   scriptmess^.rm_Args[0] := CreateArgstring(s, Length(s));
  195.   s := 'CON:/100/450//Skript-Aufruf "'+scriptnames[i]+'", Abbruch: Ctrl-C';
  196.   IF silentrexx THEN
  197.     s := s + '/INACTIVE'
  198.   ELSE
  199.     s := s + '/SCREEN'+pubsname;
  200.   Reset(fenster, s);
  201.   scriptmess^.rm_Stdin := FileHandle(fenster);
  202.   scriptmess^.rm_Stdout := FileHandle(fenster);
  203.   Forbid;
  204.   rxmp := FindPort('REXX');
  205.   IF rxmp<>Nil THEN BEGIN
  206.     PutMsg(rxmp, p_Message(scriptmess)); 
  207.     Permit;
  208.     FOR i := 1 TO rxscripts DO
  209.       ghostme($060300 + i*$100, True);
  210.     rexxecute := True;
  211.   END ELSE BEGIN
  212.     Permit; 
  213.     Close(fenster);
  214.     DeleteArgstring(scriptmess^.rm_Args[0]);
  215.     DeleteRexxMsg(scriptmess); scriptmess := Nil;
  216.   END;
  217. END;
  218.  
  219. PROCEDURE scriptscan;
  220. { Liest das "rexx/"-Verzeichnis }
  221. VAR scanner: AnchorPath;
  222.     pattern: str80;
  223.     result: Long;
  224. BEGIN
  225.   rxscripts := 0;
  226.   pattern := rexxpath + '~(#?.info)';
  227.   scanner.ap_BreakBits := 0;
  228.   scanner.ap_Strlen := 0;
  229.   result := MatchFirst(^pattern, ^scanner);
  230.   WHILE result=0 DO BEGIN
  231.     IF (scanner.ap_Info.fib_DirEntryType<0) AND (rxscripts<10) THEN BEGIN
  232.       Inc(rxscripts); 
  233.       scriptnames[rxscripts] := scanner.ap_Info.fib_FileName;
  234.     END;
  235.     result := MatchNext(^scanner);
  236.   END;
  237.   MatchEnd(^scanner);
  238. END;
  239.  
  240. PROCEDURE ghostme{(code: Long; really: Boolean)};
  241. { Menüpunkt abschalten/wieder einschalten }
  242. VAR it: p_MenuItem;
  243.     m,i,s: Integer;
  244.     syscode: Word;
  245. BEGIN
  246.   m := (code SHR 16) - 1;
  247.   i := ((code SHR 8) AND $FF) - 1;
  248.   s := (code AND $FF) - 1;
  249.   syscode := m OR (i SHL 5) OR (s SHL 11);
  250.   it := ItemAddress(Strip,syscode);
  251.   IF it=Nil THEN Exit;
  252.   IF really THEN
  253.     OffMenu(MyWindow, syscode)
  254.   ELSE                       
  255.     OnMenu(MyWindow, syscode);
  256. END;
  257.  
  258. PROCEDURE checkme{(code: Long; really: Boolean)};
  259. { Menuehäkchen setzen/löschen }
  260. VAR it: p_MenuItem;
  261.     m,i,s: Integer;
  262.     syscode: Word;
  263. BEGIN
  264.   m := (code SHR 16) - 1;
  265.   i := ((code SHR 8) AND $FF) - 1;
  266.   s := (code AND $FF) - 1;
  267.   syscode := m OR (i SHL 5) OR (s SHL 11);
  268.   it := ItemAddress(Strip,syscode);
  269.   IF it=Nil THEN Exit;
  270.   IF really THEN
  271.     it^.Flags := it^.Flags OR CHECKED
  272.   ELSE
  273.     it^.Flags := it^.Flags AND NOT CHECKED;
  274. END;
  275.  
  276. FUNCTION has_check{(code: Long): Boolean};
  277. { Menuehäkchen abfragen }
  278. VAR it: p_MenuItem;
  279.     m,i,s: Integer;
  280.     syscode: Word;
  281. BEGIN
  282.   m := (code SHR 16) - 1;
  283.   i := ((code SHR 8) AND $FF) - 1;
  284.   s := (code AND $FF) - 1;
  285.   syscode := m OR (i SHL 5) OR (s SHL 11);
  286.   it := ItemAddress(Strip,syscode);
  287.   IF it<>Nil THEN
  288.     has_check := (it^.Flags AND CHECKED)<>0;
  289. END;
  290.  
  291. FUNCTION ja_nein{(message: Str): Boolean};
  292. VAR easy: EasyStruct;
  293.     idcmp: Long;
  294. BEGIN
  295.   idcmp := 0;
  296.   easy := EasyStruct(SizeOf(EasyStruct), 0, 'VideoText Request',
  297.                      '%s', 'JA|NEIN');
  298.   ja_nein := EasyRequestArgs(MyWindow, ^easy, ^idcmp, ^message) = 1;
  299. END;
  300.  
  301. FUNCTION ask_and_kill{(name: Str; ask: Boolean): Boolean};
  302. VAR easy: EasyStruct;
  303.     idcmp, size: Long;
  304.     arglist: ARRAY[1..2] OF Long;
  305.     datei: Text;
  306. BEGIN
  307.   ask_and_kill := False;
  308.   IF NOT ask THEN BEGIN
  309.     ask_and_kill := DeleteFile(name)<>0;
  310.     Exit;
  311.   END;
  312.   Reset(datei,name);
  313.   IF IOResult<>0 THEN
  314.     Exit;
  315.   size := FileSize(datei);
  316.   Close(datei);
  317.   idcmp := 0;
  318.   easy := EasyStruct(SizeOf(EasyStruct),0,'VideoText Request',
  319.          '"%s"'\n'(%ld Byte) löschen?','JA|NEIN');
  320.   arglist[1] := Long(name);
  321.   arglist[2] := size;
  322.   IF EasyRequestArgs(MyWindow,^easy,^idcmp,^arglist) = 1 THEN
  323.     ask_and_kill := DeleteFile(name)<>0;
  324. END;
  325.  
  326. FUNCTION stringrequest{(meldung: str80; VAR eingabe: str80): Boolean};
  327. { Erzeugt einen Intuition-Requester mit Stringgadget. }
  328. TYPE IntArr10 = ARRAY [1..10] OF Integer;
  329. CONST chars=20;
  330. VAR i,p,l: Integer;
  331.     Msg: p_IntuiMessage;
  332.     ende: Boolean;
  333.     class: Long;
  334.     b,h,charx,chary: Word;
  335.     buf,ubuf: str80;
  336.     muell: ARRAY[0..31] OF Byte;
  337.     MyRequest: Requester; STATIC;
  338.     TextGad: Gadget; STATIC;
  339.     TextInfo: StringInfo; STATIC;
  340.     ITxt: ARRAY[1..5] OF IntuiText; STATIC;
  341.     Borders: ARRAY[1..6] OF Border; STATIC;
  342.     TextBordXY,MainBordXY: IntArr10; STATIC;    
  343. BEGIN
  344.   stringrequest := False;
  345.   { Screenfont bestimmt das Aussehen des Requesters: }
  346.   charx := MyScreen^.RastPort.TxWidth;  
  347.   chary := MyScreen^.RastPort.TxHeight;
  348.   buf := eingabe; ubuf := '';
  349.   ITxt[1] := IntuiText(1,3,JAM1,15,6,MyScreen^.Font,meldung,Nil);
  350.   b := IntuiTextLength(^ITxt[1]) + 30;
  351.   IF b<chars*8 + 30  THEN b := chars*8 + 30;
  352.   h := chary + 8 + 20;
  353.   TextBordXY := IntArr10(-1,8,chars*8,8,chars*8,-1,-1,-1,-1,8);
  354.   Borders[1] := Border(0,0,2,0,JAM1,3,^TextBordXY,^Borders[2]);
  355.   Borders[2] := Border(0,0,1,0,JAM1,3,^TextBordXY[5],Nil);
  356.   TextInfo := StringInfo(^buf,^ubuf,0,79,0,0,0,0,0,0,Nil,0,Nil);
  357.   TextGad := Gadget(Nil,(b-8*chars) DIV 2,chary+12,8*chars,8,GFLG_GADGHCOMP,
  358.     GACT_RELVERIFY OR GACT_ENDGADGET, GTYP_STRGADGET OR GTYP_REQGADGET,
  359.     ^Borders[1], Nil,Nil,0,^TextInfo,2,Nil);
  360.   MainBordXY := IntArr10(0,h-1,b-1,h-1,b-1,0,0,0,0,h-1);
  361.   Borders[3] := Border(0,0,1,0,JAM1,3,^MainBordXY,^Borders[4]);
  362.   Borders[4] := Border(0,0,2,0,JAM1,3,^MainBordXY[5],Nil);
  363.   MyRequest := Requester(Nil,40,90,b,h,0,0,^TextGad,^Borders[3],
  364.       ^ITxt[1],0,3,Nil,muell,Nil,Nil,Nil,muell);
  365.   IF Request(^MyRequest,MyWindow) THEN BEGIN { Ereignisse abfragen }
  366.     ende := False;
  367.     REPEAT
  368.       REPEAT              { Schleife, da mehrere Ereignisse möglich }
  369.         Msg := Get_Msg(MyWindow^.UserPort);
  370.         IF Msg<>Nil THEN BEGIN
  371.           class := Msg^.Class;
  372.           Reply_Msg(Msg);             { so schnell wie möglich antworten! }
  373.           IF class=IDCMP_REQSET THEN
  374.             IF NOT ActivateGadget(^TextGad,MyWindow,^MyRequest) THEN;
  375.           IF class=IDCMP_REQCLEAR THEN ende := True;
  376.         END;
  377.       UNTIL Msg=Nil;
  378.       IF NOT ende THEN class := Wait(-1);
  379.     UNTIL ende;
  380.     IF buf<>'' THEN BEGIN
  381.       stringrequest := True;
  382.       eingabe := buf;
  383.     END;
  384.   END;
  385. END;
  386.  
  387. FUNCTION fileselect{(was_los: str80; speichern: Boolean;
  388.                                    VAR selected: str80): Boolean};
  389. { Benutzt den Filerequester der asl.library }
  390. VAR i,p,l: Integer;
  391.     Req: p_FileRequester;
  392.     pfad,name: str80;
  393. BEGIN
  394.   fileselect := False;
  395.   l := Length(selected);
  396.   { selected in pfad und name spalten }
  397.   p := 0; FOR i := 1 TO l DO
  398.     IF selected[i] IN ['/',':'] THEN p := i;
  399.   IF p=0 THEN pfad := '' ELSE pfad := Copy(selected,1,p);
  400.   IF p=l THEN name := '' ELSE name := Copy(selected,p+1,l-p);
  401.   IF AslBase<>Nil THEN BEGIN            { *** "asl.library" benutzen }
  402.     Tags[1] := TagItem(ASL_Hail,Long(^was_los));
  403.     Tags[2] := TagItem(ASL_Dir,Long(^pfad));
  404.     Tags[3] := TagItem(ASL_File,Long(^name));
  405.     Tags[4] := TagItem(ASL_Window,Long(MyWindow));
  406.     Tags[5] := TagItem(ASL_FuncFlags,FILF_SAVE);
  407.     i := 5; IF speichern THEN Inc(i);
  408.     Tags[i] := TagItem(TAG_DONE,0);
  409.     Req := AllocAslRequest(ASL_FileRequest,^Tags);
  410.     IF Req<>NIL THEN BEGIN
  411.       IF RequestFile(Req) THEN
  412.         IF Req^.rf_File<>'' THEN BEGIN
  413.           fileselect := True;
  414.           selected := Req^.rf_Dir;
  415.           IF NOT AddPart(selected, Req^.rf_File, 80) THEN { panic ;-) };
  416.         END;
  417.       FreeAslRequest(Req);
  418.     END;
  419.   END;
  420. END;
  421.  
  422. PROCEDURE create_icon{(src, dest: Str)};
  423. VAR icon: p_DiskObject;
  424. BEGIN
  425.   IF (IconBase<>Nil) AND (src<>'') THEN BEGIN
  426.     icon := GetDiskObject(src);
  427.     IF icon<>Nil THEN BEGIN
  428.       icon^.do_CurrentX := NO_ICON_POSITION;
  429.       icon^.do_CurrentY := NO_ICON_POSITION;
  430.       icon^.do_Type := WBPROJECT;
  431.       IF NOT PutDiskObject(dest,icon) THEN;
  432.       FreeDiskObject(icon);
  433.     END;
  434.   END;
  435. END;
  436.  
  437. PROCEDURE append_datestr{(VAR s: str80; smart: Boolean)};
  438. { Hängt das aktuelle Datum in der Form .15-08-96 an den übergebenen }
  439. { Filenamen an. Ist das Datum dort schon vorhanden, passiert nichts, für }
  440. { smart=True wird es in dem Fall sogar entfernt. }
  441. VAR s1,s2,s3: String[LEN_DATSTRING];
  442.     dt: DateTime;
  443.     i: Integer;
  444. BEGIN
  445.   IF _DateStamp(^dt.dat_Stamp)<>Nil THEN;
  446.   dt.dat_Format := datestyle;
  447.   dt.dat_Flags := 0;
  448.   dt.dat_StrDay := s1;
  449.   dt.dat_StrDate := s2;
  450.   dt.dat_StrTime := s3;
  451.   IF DateToStr(^dt)<>0 THEN BEGIN
  452.     i := Pos(s2,s);
  453.     IF i=0 THEN
  454.       s := s+'.'+s2
  455.     ELSE IF smart THEN
  456.       s[i-1] := #0;
  457.   END;
  458. END;
  459.  
  460. PROCEDURE desaster{(meldung: Str80)};
  461. { erzeugt einen Alert }
  462. VAR egal: Boolean;
  463.     buf: Str80;
  464.     xpos: Integer;
  465. BEGIN
  466.   xpos := 320 - 4*Length(meldung);
  467.   buf := '   '+meldung;
  468.   buf[1] := Chr(Hi(xpos)); buf[2] := Chr(Lo(xpos));
  469.   buf[3] := Chr(18);
  470.   buf [Length(meldung)+5] := Chr(0);
  471.   egal := DisplayAlert(RECOVERY_ALERT,buf,32);
  472. END;
  473.  
  474. PROCEDURE stretch_line{(zeile, sp0, sp1: Integer)};
  475. { Streckt eine Textzeile am Bildschirm von sp0 bis einschließlich sp1 auf }
  476. { doppelte Höhe. }
  477. { Zeilen und Spalten werden, wie bei GotoXY üblich, ab 1 gezählt! }
  478. VAR charx,chary,i,y0,x0,breite: Integer;
  479. BEGIN
  480.   charx := MyWindow^.RPort^.TxWidth;
  481.   chary := MyWindow^.RPort^.TxHeight;
  482.   x0 := (sp0-1)*charx; breite := (sp1-sp0+1)*charx;
  483.   y0 := (zeile-1)*chary;
  484.   FOR i := chary-1 DOWNTO 0 DO BEGIN
  485.     ClipBlit(MyWindow^.RPort,x0,y0+i,MyWindow^.RPort,x0,y0+2*i,breite,1,$C0);
  486.     ClipBlit(MyWindow^.RPort,x0,y0+i,MyWindow^.RPort,x0,y0+2*i+1,breite,1,$C0);
  487.   END;
  488. END;
  489.  
  490. PROCEDURE raster_line{(zeile, sp0, sp1: Integer; farbe: Word)};
  491. { Grafikzeichen einer Zeile in seperate Rasterpunkte zerlegen, dazu dient }
  492. { Zeichen #159 des videotext.font }
  493. VAR charx,chary,baseline,y0,x0,i,anz: Integer;
  494.     dummy: str80;
  495.     egal: Long;
  496. BEGIN
  497.   charx := MyWindow^.RPort^.TxWidth;
  498.   chary := MyWindow^.RPort^.TxHeight;
  499.   baseline := MyWindow^.RPort^.TxBaseline;
  500.   x0 := (sp0-1)*charx; y0 := (zeile-1)*chary + baseline;
  501.   anz := sp1-sp0+1;
  502.   FOR i := 1 TO anz DO dummy[i] := #159;
  503.   SetAPen(MyWindow^.RPort,farbe); SetDrMd(MyWindow^.RPort,JAM1);
  504.   Move(MyWindow^.RPort,x0,y0); egal := _Text(MyWindow^.RPort,dummy,anz);
  505. END;
  506.  
  507. PROCEDURE scroll_text{(zl0,zl1, sp0,sp1, dy,dx: Integer)};
  508. { einen Textblock verschieben, benutzt natürlich ScrollRaster() }
  509. { Zeilen und Spalten werden, wie bei GotoXY üblich, ab 1 gezählt! }
  510. VAR charx,chary,i,x0,y0,x1,y1: Integer;
  511. BEGIN
  512.   charx := MyWindow^.RPort^.TxWidth;
  513.   chary := MyWindow^.RPort^.TxHeight;
  514.   dx := dx*charx; dy := dy*chary;
  515.   x0 := (sp0-1)*charx; x1 := sp1*charx-1;
  516.   y0 := (zl0-1)*chary; y1 := zl1*chary-1;
  517.   ScrollRaster(MyWindow^.RPort,dx,dy,x0,y0,x1,y1);
  518. END;
  519.  
  520. FUNCTION newfontno{: Boolean};
  521. { den über <fontno> eingestellten Font öffnen und darstellen }
  522. { Kann fehlschlagen, wenn der Font nicht da ist, oder wenn die gewählte }
  523. { Größe nicht zu den aktuellen Fensterausmaßen paßt. }
  524. VAR teleAttr: TextAttr;
  525.     lastFont: p_TextFont;
  526.     l: Long;
  527.     msg: str80;
  528. BEGIN
  529.   newfontno := True;
  530.   IF DiskFontBase=Nil THEN Exit;
  531.   lastFont := teleFont;
  532.   teleAttr := TextAttr('videotext.font',9,FS_NORMAL,FPF_DISKFONT);
  533.   IF fontno=2 THEN
  534.     IF MyWindow^.GZZHeight>=390 THEN
  535.       teleAttr.ta_YSize := 15
  536.     ELSE BEGIN
  537.       fontno := 1;
  538.       newfontno := False;
  539.     END;
  540.   teleFont := OpenDiskFont(^teleAttr);
  541.   IF teleFont<>Nil THEN BEGIN
  542.     IF lastFont<>Nil THEN CloseFont(lastFont);
  543.     l := SetFont(MyWindow^.RPort,teleFont);
  544.   END ELSE BEGIN
  545.     msg := 'Can''t open font: videotext/'+IntStr(teleAttr.ta_YSize)+' !!!';
  546.     desaster(msg);
  547.     newfontno := False;
  548.     teleFont := lastFont;
  549.   END;
  550. END;
  551.  
  552. FUNCTION iffdump{(VAR filename: str80; withicon: Boolean): Boolean};
  553. { IFF-Bild erzeugen }
  554. { Annahmen: Die VT-Seite beginnt in Zeile 0, belegt die letzten 41 (!) }
  555. { Textspalten und überdeckt damit nicht mehr als 640 Pixel (=80 Byte). }
  556. VAR i, j, k, zeile, bunt, packbar: Integer;
  557.     rows, bpr, x0, w: Integer;
  558.     l: Long;
  559.     s: str80;
  560.     bytes: ^ARRAY [1..1000] OF Char;
  561.     tempscr: p_Screen;
  562.     datei: Text;
  563. PROCEDURE putshort(w: Word);
  564.   BEGIN Write(datei,chr(Hi(w)),chr(Lo(w))); END;
  565. PROCEDURE putlong(l: Long);
  566.   BEGIN putshort(Word(l SHR 16)); putshort(Word(l AND $FFFF)); END;
  567. BEGIN
  568.   iffdump := False;
  569.   Rewrite(datei, filename);
  570.   IF IOresult<>0 THEN     { wahrscheinlich 'Object in use' }
  571.     Exit;
  572.   IF withicon THEN
  573.     create_icon('Icons/IFF', filename);
  574.   { Abmessungen und Ort des zu speichernden Bildes: }
  575.   w := MyWindow^.RPort^.TxWidth;
  576.   bpr := (40 * w) DIV 8;
  577.   rows := 24 * MyWindow^.RPort^.TxHeight;
  578.   x0 := w * (MyWindow^.GZZWidth DIV w - 41); IF x0<0 THEN x0 := 0;
  579.   { Temporären Screen in einem Bitplane-Screenmode (LoRes) einrichten: }
  580.   Tags[1] := TagItem(SA_Width, 8*bpr);
  581.   Tags[2] := TagItem(SA_Height, 2);     { Höhe 1 ist nicht zulässig! }
  582.   Tags[3] := TagItem(SA_Depth, 3);
  583.   Tags[4] := TagItem(SA_DisplayID, 0);
  584.   Tags[5] := TagItem(SA_Behind, 1);
  585.   Tags[6] := TagItem(TAG_DONE, 0);
  586.   tempscr := OpenScreenTagList(Nil,^Tags[1]);
  587.   IF tempscr=Nil THEN BEGIN
  588.     Close(datei); Exit;
  589.   END;
  590.   { IFF-ILBM erzeugen, LoRes, 3 Bitplanes }
  591.   Write(datei,'FORM'); putlong(10000);  { wird später korrigiert }
  592.   Write(datei,'ILBM');
  593.   Write(datei,'BMHD'); putlong(20);
  594.   putshort(8*bpr); putshort(rows); { Breite, Höhe der Bitmap }
  595.   putshort(0); putshort(0); { x/y-Offset }
  596.   Write(datei,Chr(3)); { 3 Bitplanes }
  597.   Write(datei,Chr(0)); { keine Maske }
  598.   Write(datei,Chr(1)); { Grafikdaten mit Byte-Running gepackt !!! }
  599.   Write(datei,Chr(0)); { Füllbyte }
  600.   putshort(0); { transparente Farbe }
  601.   Write(datei, Chr(10), Chr(11));  { x/y-Verhältnis ~1:1 }
  602.   putshort(8*bpr); putshort(rows); { Breite, Höhe des Bildschirms }
  603.   Write(datei,'CMAP'); putlong(24);
  604.   FOR j := 0 TO 7 DO
  605.     Write(datei, Chr($F0*(j AND 1)), Chr($78*(j AND 2)), Chr($3C*(j AND 4)));
  606.   Write(datei,'BODY'); putlong(10000);    { Wert wird später korrigiert }
  607.   FOR zeile := 0 TO rows-1 DO BEGIN
  608.     ClipBlit(MyWindow^.RPort,x0,zeile,^tempscr^.RastPort,0,0,8*bpr,1,$C0);
  609.     FOR i := 0 TO 2 DO BEGIN
  610.       bytes := Ptr(tempscr^.RastPort.BitMap^.Planes[i]);
  611.       { Zeile von bytes[] nach s[] packen (Byte-Running): }
  612.       j := 1; k := 0;
  613.       bunt := 0;
  614.       REPEAT
  615.         packbar := 1;
  616.         WHILE (bytes^[j+packbar]=bytes^[j+packbar-1]) AND (j+packbar<bpr) DO
  617.           Inc(packbar);
  618.         IF packbar>2 THEN BEGIN { lohnt packen? }
  619.           Inc(k); s[k] := Chr(257-packbar); Inc(k); s[k] := bytes^[j];
  620.           j := j + packbar; bunt := 0;
  621.         END ELSE BEGIN
  622.           Inc(bunt); IF bunt=1 THEN Inc(k);
  623.           Inc(k); s[k] := bytes^[j]; s[k-bunt] := Chr(bunt-1);
  624.           Inc(j);
  625.         END;
  626.       UNTIL j>bpr;
  627.       BlockWrite(datei,s,k); IF IOResult<>0 THEN BEGIN 
  628.         Close(datei); Exit; { wahrscheinlich Disk full oder so was }
  629.       END; 
  630.     END;
  631.   END;
  632.   { Chunk-Größen korrigieren }
  633.   l := FileSize(datei);
  634.   IF Odd(l) THEN BEGIN Write(datei,Chr(0)); Inc(l); END;
  635.   Seek(datei,4); putlong(l-8);
  636.   Seek(datei,76); putlong(l-80);
  637.   Close(datei);
  638.   IF CloseScreen(tempscr) THEN;
  639.   iffdump := True;
  640. END;
  641.  
  642. PROCEDURE busy_pointer;
  643. BEGIN
  644.   IF BusyPointerData<>Nil THEN
  645.     SetPointer(MyWindow, BusyPointerData, 16, 16, -6, 0);
  646. END;
  647.  
  648. PROCEDURE normal_pointer;
  649. BEGIN
  650.   ClearPointer(MyWindow);
  651. END;
  652.  
  653. PROCEDURE showscreen{(which: Integer)};
  654. { -1: mein Screen nach hinten }
  655. {  0: Workbench nach vorne }
  656. { +1: mein Screen nach vorne }
  657. { +2: mein Screen nach vorne und aktivieren }
  658. BEGIN     
  659.   IF which>0 THEN BEGIN
  660.     ScreenToFront(MyScreen);
  661.     IF which>1 THEN IF ActivateWindow(MyWindow)<>0 THEN;
  662.   END ELSE IF which<0 THEN
  663.     ScreenToBack(MyScreen)
  664.   ELSE
  665.     IF NOT WBenchToFront THEN { Workbench gar nicht offen, na toll };
  666. END;
  667.  
  668. PROCEDURE getpalette;
  669. VAR i, j: Integer;
  670. BEGIN
  671.   FOR i := 0 TO 7 DO BEGIN
  672.     j := (colperm SHR (4*(7-i))) AND $F;
  673.     palette[j] := GetRGB4(MyScreen^.ViewPort.ColorMap, i);
  674.   END;
  675. END;
  676.  
  677. PROCEDURE telltime{(VAR day,min,tic: Long)};
  678. VAR time: DateStamp;
  679. BEGIN
  680.   IF _DateStamp(^time)<>Nil THEN BEGIN
  681.     day := time.ds_Days;
  682.     min := time.ds_Minute;
  683.     tic := time.ds_Tick;
  684.   END;
  685. END;
  686.  
  687. PROCEDURE force_time{(VAR s: Str80)};
  688. { setzt die Systemzeit (Tageszeit), Datum bleibt unverändert }
  689. VAR port: ^MsgPort;
  690.     t_ioreq: ^TimeRequest;
  691.     err: Integer;
  692.     secs,w: Long;
  693.     i,j: Integer;
  694. CONST spd=60*60*24;
  695. BEGIN
  696.   { Uhrzeit-String "09:12:35", "912/35" o. ä. in Sekunden umrechnen }
  697.   secs := 0; j := 0; w := 1; { w: Wert der Ziffer }
  698.   FOR i := Length(s) DOWNTO 1 DO BEGIN
  699.     IF s[i] IN ['0'..'9'] THEN BEGIN
  700.       secs := secs + w*(Ord(s[i])-48);
  701.       Inc(j);
  702.       CASE j OF
  703.         1,3,5: w := 10*w;
  704.         2,4: w := 6*w;
  705.         OTHERWISE w := 0;
  706.       END;
  707.     END;
  708.   END;
  709.   IF j<5 THEN Exit; { das kann keine Uhrzeit gewesen sein }
  710.   { der ganze device-Ärger: }
  711.   port := CreateMsgPort; 
  712.   t_ioreq := CreateIORequest(port,SizeOf(TimeRequest));
  713.   IF OpenDevice('timer.device',UNIT_VBLANK,Ptr(t_ioreq),0)=0 THEN BEGIN
  714.     { Uhrzeit erst lesen: }
  715.     t_ioreq^.tr_node.io_Command := TR_GETSYSTIME;
  716.     err := DoIO(Ptr(t_ioreq));
  717.     { Tageszeit ändern und neu setzten: }
  718.     t_ioreq^.tr_node.io_Command := TR_SETSYSTIME;
  719.     WITH t_ioreq^.tr_time DO BEGIN
  720.       tv_secs := (tv_secs DIV spd)*spd + secs; tv_micro := 0;
  721.     END;
  722.     err := DoIO(Ptr(t_ioreq));
  723.     { Und tschüss: }
  724.     CloseDevice(Ptr(t_ioreq));
  725.   END;
  726.   DeleteIORequest(t_ioreq);
  727.   DeleteMsgPort(port);
  728. END;
  729.  
  730. PROCEDURE clip_it{(s: Str; len: Long)};
  731. { String ins Clipboard schreiben }
  732. VAR err: Integer;
  733. BEGIN
  734.   IF clip_open THEN BEGIN
  735.     clipreq^.io_Command := CMD_WRITE;
  736.     clipreq^.io_Data := s;
  737.     clipreq^.io_Length := len;
  738.     err := DoIO(Ptr(clipreq));
  739.   END;
  740. END;
  741.  
  742. PROCEDURE start_clip{(size: Long)};
  743. BEGIN
  744.   IF clip_open THEN Exit;
  745.   clip_port := CreateMsgPort;
  746.   clipreq := CreateIORequest(clip_port,SizeOf(IOClipReq));
  747.   IF OpenDevice('clipboard.device',PRIMARY_CLIP,Ptr(clipreq),0)=0 THEN BEGIN
  748.     clipreq^.io_Offset := 0;
  749.     clipreq^.io_ClipID := 0;
  750.     clip_open := True;
  751.     clip_it('FORM',4); { IFF-Header }
  752.     size := size + 12; clip_it(Ptr(^size),4); size := size - 12;
  753.     clip_it('FTXTCHRS',8);
  754.     clip_it(Ptr(^size),4);
  755.   END ELSE BEGIN
  756.     DeleteIORequest(clipreq);
  757.     DeleteMsgPort(clip_port);
  758.   END;
  759. END;
  760.  
  761. PROCEDURE end_clip;
  762. VAR err: Integer;
  763. BEGIN
  764.   IF clip_open THEN BEGIN
  765.     { melden, daß man fertig ist }
  766.     clipreq^.io_Command := CMD_UPDATE;
  767.     err := DoIO(Ptr(clipreq));
  768.     { Und tschüss: }
  769.     CloseDevice(Ptr(clipreq));
  770.     DeleteIORequest(clipreq);
  771.     DeleteMsgPort(clip_port);
  772.     clip_open := False;
  773.   END;
  774. END;
  775.  
  776. { *** mein Menü: }
  777.  
  778. PROCEDURE create_menu;
  779. CONST tog = CHECKIT OR MENUTOGGLE;
  780.       mut = CHECKIT;
  781. VAR egal: Boolean;
  782.     i,j,stacked: Integer;
  783.     s: ^str80;
  784.     gtlib: p_Library;
  785. FUNCTION strcopy(s: Str): Str;
  786. { einen String in den globalen Stringpuffer kopieren }
  787. VAR i: Integer;
  788.     s2: ^str80;
  789. BEGIN
  790.   strcopy := ^strstack[stacked]; s2 := s; i := 0;
  791.   REPEAT
  792.     Inc(i); strstack[stacked] := s2^[i]; Inc(stacked); 
  793.   UNTIL s2^[i]=chr(0);
  794. END;
  795. BEGIN
  796.   stacked := 1;
  797.   TheMenu := NMArray(
  798.     NewMenu(NM_TITLE,0, 'Projekt',           Nil, 0, 0, Nil),
  799.     NewMenu(NM_ITEM, 0, 'Info',              '?', 0, 0, Nil),
  800.     NewMenu(NM_ITEM, 0, 'Hilfe: Help',       Nil, 0, 0, Nil),
  801.     NewMenu(NM_ITEM, 0, 'Parameter sichern', Nil, 0, 0, Nil),
  802.     NewMenu(NM_ITEM, 0,  Str(NM_BARLABEL),   Nil, 0, 0, Nil),
  803.     NewMenu(NM_ITEM, 0, 'Ende',              'Q', 0, 0, Nil),
  804.     { 6 }
  805.     NewMenu(NM_TITLE,0, 'Datei',                   Nil, 0,   0, Nil),
  806.     NewMenu(NM_ITEM, 0, 'VT-Format laden',         'L', 0,   0, Nil),
  807.     NewMenu(NM_ITEM, 0,  Str(NM_BARLABEL),         Nil, 0,   0, Nil),
  808.     NewMenu(NM_ITEM, 0, 'Ausgabeformat',           Nil, 0,   0, Nil),
  809.     NewMenu(NM_SUB,  0, 'ASCII',                   'A', mut, %10, Nil),
  810.     NewMenu(NM_SUB,  0, 'VT',                      'V', mut, %01, Nil),
  811.     NewMenu(NM_ITEM, 0, 'Icons erzeugen: I',       Nil, tog, 0, Nil),
  812.     NewMenu(NM_ITEM, 0, Str(NM_BARLABEL),          Nil, 0,   0, Nil),
  813.     NewMenu(NM_ITEM, 0, 'Dateinamen',              Nil, 0,   0, Nil),
  814.     NewMenu(NM_SUB,  0, 'ändern ...',              'N', 0,   0, Nil),
  815.     NewMenu(NM_SUB,  0, 'nach Titelzeile: Ctrl-N', Nil, 0,   0, Nil),
  816.     NewMenu(NM_SUB,  0, 'Datum anhängen',          'D', 0,   0, Nil),
  817.     NewMenu(NM_ITEM, 0, 'Datei löschen',           'K', 0,   0, Nil),
  818.     { 13 }
  819.     NewMenu(NM_TITLE,0, 'Seiten',                      Nil, 0, 0, Nil),
  820.     NewMenu(NM_ITEM, 0, 'Rätseltaste: ?',              Nil, 0, 0, Nil),
  821.     NewMenu(NM_ITEM, 0, 'Neuaufbau: Space',            Nil, 0, 0, Nil),
  822.     NewMenu(NM_ITEM, 0, 'Automatik',                   'M', 0, 0, Nil),
  823.     NewMenu(NM_ITEM, 0, 'alle gesehen',                '.', 0, 0, Nil),
  824.     NewMenu(NM_ITEM, 0, Str(NM_BARLABEL),              Nil, 0, 0, Nil),
  825.     NewMenu(NM_ITEM, 0, 'Text suchen ...',             'H', 0, 0, Nil),
  826.     NewMenu(NM_ITEM, 0, 'Weitersuchen: H',             Nil, 0, 0, Nil),
  827.     NewMenu(NM_ITEM, 0, Str(NM_BARLABEL),              Nil, 0, 0, Nil),
  828.     NewMenu(NM_ITEM, 0, 'Textausdruck',                'P', 0, 0, Nil),
  829.     NewMenu(NM_ITEM, 0, 'IFF-Bild ...',                'I', 0, 0, Nil),
  830.     NewMenu(NM_ITEM, 0, 'Seite speichern',             Nil, 0, 0, Nil),
  831.     NewMenu(NM_SUB,  0, 'nur diese: S',                Nil, 0, 0, Nil),
  832.     NewMenu(NM_SUB,  0, 'mit allen Unterseiten: Shift-S', Nil, 0, 0, Nil),
  833.     NewMenu(NM_SUB,  0, 'alle ab Cursor: Ctrl-S',      Nil, 0, 0, Nil),
  834.     NewMenu(NM_SUB,  0, 'alle',                        'S', 0, 0, Nil),
  835.     NewMenu(NM_ITEM, 0, 'Ins Clipboard',               'C', 0, 0, Nil),
  836.     NewMenu(NM_ITEM, 0, Str(NM_BARLABEL),              Nil, 0, 0, Nil),
  837.     NewMenu(NM_ITEM, 0, 'Seite löschen',               Nil, 0, 0, Nil),
  838.     NewMenu(NM_SUB,  0, 'nur diese: Del',              Nil, 0, 0, Nil),
  839.     NewMenu(NM_SUB,  0, 'mit a. Unterseiten: Shift-Del', Nil, 0, 0, Nil),
  840.     NewMenu(NM_SUB,  0, 'alle ab Cursor: Ctrl-Del',    Nil, 0, 0, Nil),
  841.     NewMenu(NM_SUB,  0, 'alle: Alt-Del',               Nil, 0, 0, Nil),
  842.     { 23 }
  843.     NewMenu(NM_TITLE,0, 'Anfordern',               Nil, 0, 0, Nil),
  844.     NewMenu(NM_ITEM, 0, 'Seite 100: f1',           Nil, 0, 0, Nil),
  845.     NewMenu(NM_ITEM, 0, 'diese Seite nochmal: f8', Nil, 0, 0, Nil),
  846.     NewMenu(NM_ITEM, 0, 'nicht gefundene nochmal: F8', Nil, 0, 0, Nil),
  847.     NewMenu(NM_ITEM, 0, 'Seitenvorauswahl',        Nil, 0, 0, Nil),
  848.     NewMenu(NM_SUB,  0, 'erste: f10',              Nil, 0, 0, Nil),
  849.     NewMenu(NM_SUB,  0, 'zweite: F10',             Nil, 0, 0, Nil),
  850.     NewMenu(NM_SUB,  0, '3.: Alt-f10',             Nil, 0, 0, Nil),
  851.     NewMenu(NM_SUB,  0, '4.: Alt-F10',             Nil, 0, 0, Nil),
  852.     NewMenu(NM_ITEM, 0, 'Stichprobe: f6',          Nil, 0, 0, Nil),
  853.     NewMenu(NM_ITEM, 0, 'gefilterte Stichprobe: F6', Nil, 0, 0, Nil),
  854.     NewMenu(NM_ITEM, 0, Str(NM_BARLABEL),          Nil, 0, 0, Nil),
  855.     NewMenu(NM_ITEM, 0, 'ins Clipboard schreiben', Nil, 0, 0, Nil),
  856.     NewMenu(NM_SUB,  0, 'Seitennummern',           '#', 0, 0, Nil),
  857.     NewMenu(NM_SUB,  0, 'Sendernamen',             '+', 0, 0, Nil),
  858.     NewMenu(NM_ITEM, 0, 'Vorauswahl editieren: f9', Nil, 0, 0, Nil),
  859.     NewMenu(NM_ITEM, 0, 'Senderliste editieren: F9',Nil, 0, 0, Nil),
  860.     NewMenu(NM_ITEM, 0, Str(NM_BARLABEL),          Nil, 0, 0, Nil),
  861.     NewMenu(NM_ITEM, 0, 'TOP-Verzeichnis',         Nil, 0, 0, Nil),
  862.     NewMenu(NM_SUB,  0, 'erstellen: f5',           Nil, 0, 0, Nil),
  863.     NewMenu(NM_SUB,  0, 'löschen: F5',             Nil, 0, 0, Nil),
  864.     NewMenu(NM_ITEM, 0, 'TOP-Statistik: f4',       Nil, 0, 0, Nil),
  865.     NewMenu(NM_ITEM, 0, 'Blockseiten holen: F4',   Nil, 0, 0, Nil),
  866.     NewMenu(NM_ITEM, 0, Str(NM_BARLABEL),          Nil, 0, 0, Nil),
  867.     NewMenu(NM_ITEM, 0, 'Seitensuche löschen: f7', Nil, 0, 0, Nil),
  868.     NewMenu(NM_ITEM, 0, 'einen Job löschen: F7',   Nil, 0, 0, Nil),
  869.     NewMenu(NM_ITEM, 0, 'FIFO',                    'F', tog, 0, Nil),
  870.     { 25 }
  871.     NewMenu(NM_TITLE,0, 'Extras',                    Nil, 0, 0, Nil),
  872.     NewMenu(NM_ITEM, 0, 'Test/Uhr: T',               Nil, tog, 0, Nil),
  873.     NewMenu(NM_ITEM, 0, 'Uhrzeit übernehmen',        'T', 0, 0, Nil),
  874.     NewMenu(NM_ITEM, 0, 'Sendernamen zeigen: N',     Nil, tog, 0, Nil),
  875.     NewMenu(NM_ITEM, 0, Str(NM_BARLABEL),            Nil, 0, 0, Nil),
  876.     NewMenu(NM_ITEM, 0, 'Decoder-Reset: R',          Nil, 0, 0, Nil),
  877.     NewMenu(NM_ITEM, 0, 'Fernsehdarstellung',        Nil, 0, 0, Nil),
  878.     NewMenu(NM_SUB,  0, 'ein',                       Nil, mut, %110, Nil),
  879.     NewMenu(NM_SUB,  0, 'transparent',               Nil, mut, %101, Nil),
  880.     NewMenu(NM_SUB,  0, 'aus',                       Nil, mut, %011, Nil),
  881.     NewMenu(NM_ITEM, 0, 'I²C-Bus sperren',           'B', tog, 0, Nil),
  882.     NewMenu(NM_ITEM, 0, Str(NM_BARLABEL),            Nil, 0, 0, Nil),
  883.     NewMenu(NM_ITEM, 0, 'Font',                      Nil, 0, 0, Nil),
  884.     NewMenu(NM_SUB,  0, 'klein',                     Nil, mut, %10, Nil),
  885.     NewMenu(NM_SUB,  0, 'groß',                      Nil, mut, %01, Nil),
  886.     { 15 }
  887.     NewMenu(NM_TITLE,0, 'ARexx',              Nil, 0, 0, Nil),
  888.     NewMenu(NM_ITEM, 0, 'Kommandoübersicht',  'R', 0, 0, Nil),
  889.     NewMenu(NM_ITEM, 0, 'Skripts auf der WB', Nil, tog, 0, Nil),
  890.     NewMenu(NM_ITEM, 0, Str(NM_BARLABEL),     Nil, 0, 0, Nil),
  891.     NewMenu(NM_ITEM, 0, scriptnames[1],       '1', 0, 0, Nil),
  892.     NewMenu(NM_ITEM, 0, scriptnames[2],       '2', 0, 0, Nil),
  893.     NewMenu(NM_ITEM, 0, scriptnames[3],       '3', 0, 0, Nil),
  894.     NewMenu(NM_ITEM, 0, scriptnames[4],       '4', 0, 0, Nil),
  895.     NewMenu(NM_ITEM, 0, scriptnames[5],       '5', 0, 0, Nil),
  896.     NewMenu(NM_ITEM, 0, scriptnames[6],       '6', 0, 0, Nil),
  897.     NewMenu(NM_ITEM, 0, scriptnames[7],       '7', 0, 0, Nil),
  898.     NewMenu(NM_ITEM, 0, scriptnames[8],       '8', 0, 0, Nil),
  899.     NewMenu(NM_ITEM, 0, scriptnames[9],       '9', 0, 0, Nil),
  900.     NewMenu(NM_ITEM, 0, scriptnames[10],      '0', 0, 0, Nil),
  901.     { 14 }
  902.     NewMenu(NM_END, 0, Nil, Nil, 0, 0, Nil)
  903.   );
  904.   gtlib := GadToolsBase;
  905.   IF gtlib^.lib_Version>=39 THEN
  906.     FOR i := 1 TO anzmenu-1 DO BEGIN
  907.       IF Long(Ptr(TheMenu[i].nm_Label))=NM_BARLABEL THEN j := 0
  908.       ELSE j := Pos(':',TheMenu[i].nm_Label);
  909.       IF j>0 THEN BEGIN
  910.         s := strcopy(TheMenu[i].nm_Label);  { Stringkonstante umkopieren }
  911.         s^[j] := #0;           { ... und aufspalten }
  912.         TheMenu[i].nm_Label := s;
  913.         TheMenu[i].nm_CommKey := ^s^[j+2];
  914.         TheMenu[i].nm_Flags := TheMenu[i].nm_Flags OR NM_COMMANDSTRING;  
  915.         { gibt es erst ab GadTools V39 !!! }
  916.       END;
  917.     END;
  918.   { einige Menüitems (je nach Anzahl der ARexx-Skripts) abhängen: }
  919.   scriptscan;
  920.   i := anzmenu - 10 + rxscripts; IF rxscripts=0 THEN Dec(i);
  921.   TheMenu[i] := TheMenu[anzmenu];
  922.   { Menü generieren: }
  923.   Tags[1] := TagItem(GTMN_NewLookMenus,1);
  924.   Tags[2] := TagItem(TAG_DONE,0);
  925.   Strip := CreateMenusA(^TheMenu,^Tags[1]);
  926.   egal := LayoutMenusA(Strip,visinfo,^Tags[1]);
  927.   egal := SetMenuStrip(MyWindow,Strip);
  928. END;
  929.  
  930. PROCEDURE sysinit{(version: Str)};
  931. VAR i,j,breite,hoehe: Integer;
  932.     syslib: p_Library;
  933.     scr: p_Screen;
  934. BEGIN
  935.   titel := copy(version,7,length(version)-6);
  936.   { Zuerst Zeiger für den zugehörigen ExitServer initialisieren: }
  937.   IntuitionBase := Nil; GfxBase := Nil; DiskFontBase := Nil;
  938.   IconBase := Nil; AslBase := Nil; GadToolsBase := Nil; 
  939.   RexxSysBase := Nil; rexxport := Nil; replyport := Nil;
  940.   MyScreen := Nil; MyWindow := Nil; Strip := Nil; teleFont := Nil;
  941.   myprocess := Nil; BusyPointerData := Nil; 
  942.   syslib := SysBase; IF syslib^.lib_Version<36 THEN
  943.     Error('OS 2.0 required');
  944.   syslib := DosBase; IF syslib^.lib_Version<36 THEN  
  945.     Error('Need dos.library V36+!');
  946.   { Libraries etc. öffnen: }
  947.   IntuitionBase := OpenLibrary('intuition.library',36);
  948.   GfxBase := OpenLibrary(GRAPHICSNAME,0);
  949.   DiskFontBase := OpenLibrary('diskfont.library',0);
  950.   IconBase := OpenLibrary('icon.library',0);
  951.   AslBase := OpenLibrary(ASLNAME,0);
  952.   GadToolsBase := OpenLibrary('gadtools.library',0);
  953.   RexxSysBase := OpenLibrary(RXSNAME,0);
  954.   IF IntuitionBase=Nil THEN Error('Need intuition V36+!');
  955.   IF GadToolsBase=Nil THEN Error('Can''t open gadtools.library!');
  956.   IF GfxBase=Nil THEN Error('Can''t open graphics.library!');
  957.   IF DiskfontBase=Nil THEN desaster('Can''t open diskfont.library !!!');
  958.   { Screen: }
  959.   i := 0; REPEAT  { stellt mit einiger Wahrscheinlichkeit einen einmaligen }
  960.     pubsname := 'WNVT'+IntStr(i); Inc(i);   { PubScreen-Namen sicher }
  961.     scr := LockPubScreen(pubsname);
  962.     IF scr<>Nil THEN UnlockPubScreen(Nil, scr);
  963.   UNTIL scr=Nil;  
  964.   i := -1;
  965.   Tags[1] := TagItem(SA_Depth,3);
  966.   Tags[2] := TagItem(SA_DisplayID,screenmode);
  967.   Tags[3] := TagItem(SA_Title,Long(^titel));
  968.   Tags[4] := TagItem(SA_Pens,Long(^i));
  969.   Tags[5] := TagItem(SA_PubName,Long(^pubsname));
  970.   Tags[6] := TagItem(TAG_DONE,0);
  971.   MyScreen := OpenScreenTagList(Nil,^Tags[1]);
  972.   IF MyScreen=Nil THEN Error('Can''t open screen!');
  973.   i := PubScreenStatus(MyScreen, 0);   { Screen veröffentlichen }
  974.   FOR i := 0 TO 7 DO BEGIN
  975.     j := (colperm SHR (4*(7-i))) AND $F;
  976.     SetRGB4(^MyScreen^.ViewPort, i,
  977.       (palette[j] SHR 8) AND $F,(palette[j] SHR 4) AND $F,(palette[j]) AND $F);
  978.   END;
  979.   visinfo := GetVisualInfoA(MyScreen,Nil);
  980.   { Fenster und Menue: }
  981.   i := MyScreen^.BarHeight+2;
  982.   breite := MyScreen^.Width; hoehe := MyScreen^.Height - i;
  983.   Tags[1] := TagItem(WA_CustomScreen,Long(MyScreen));
  984.   Tags[2] := TagItem(WA_Left,0);
  985.   Tags[3] := TagItem(WA_Top,i); 
  986.   Tags[4] := TagItem(WA_Width,breite);
  987.   Tags[5] := TagItem(WA_Height,hoehe);
  988.   Tags[6] := TagItem(WA_IDCMP, IDCMP_MENUPICK OR IDCMP_MOUSEBUTTONS
  989.                      OR IDCMP_REQSET OR IDCMP_REQCLEAR 
  990.                      OR IDCMP_RAWKEY OR IDCMP_VANILLAKEY);
  991.   Tags[7] := TagItem(WA_Flags, WFLG_ACTIVATE OR WFLG_BORDERLESS
  992.                      OR WFLG_BACKDROP OR WFLG_NEWLOOKMENUS);
  993.   Tags[8] := TagItem(TAG_DONE,0)
  994.   MyWindow := OpenWindowTagList(Nil,^Tags[1]);
  995.   IF MyWindow=Nil THEN Error('Can''t open window!');
  996.   create_menu;
  997.   IF NOT newfontno THEN; { Font setzen }
  998.   { Console einrichten: }
  999.   Con := OpenConsole(MyWindow); SetStdIO(Con);
  1000.   BusyPointerData := Ptr(AllocMem(SizeOf(WordArr36),MEMF_CHIP));
  1001.   IF BusyPointerData<>Nil THEN
  1002.     BusyPointerData^ := WordArr36(
  1003.       $0000,$0000,
  1004.       $0400,$07C0,$0000,$07C0,$0100,$0380,$0000,$07E0,
  1005.       $07C0,$1FF8,$1FF0,$3FEC,$3FF8,$7FDE,$3FF8,$7FBE,
  1006.       $7FFC,$FF7F,$7EFC,$FFFF,$7FFC,$FFFF,$3FF8,$7FFE,
  1007.       $3FF8,$7FFE,$1FF0,$3FFC,$07C0,$1FF8,$0000,$07E0,
  1008.       $0000,$0000
  1009.     );
  1010.   { meine Task finden und System Requests auf meinen Screen umleiten }
  1011.   myprocess := Ptr(FindTask(Nil));
  1012.   IF myprocess<>Nil THEN BEGIN
  1013.     oldwindowptr := myprocess^.pr_WindowPtr;
  1014.     myprocess^.pr_WindowPtr := MyWindow;
  1015.   END;
  1016.   { ARexx-Port und Reply-Port einrichten: }
  1017.   IF RexxSysBase<>Nil THEN BEGIN
  1018.     rexxport := CreateMsgPort;
  1019.     IF rexxport<>Nil THEN BEGIN
  1020.       Forbid;
  1021.       i := 0; REPEAT
  1022.         portname := 'WNVT'+IntStr(i); Inc(i);
  1023.       UNTIL FindPort(portname)=Nil;  { einmaligen Portnamen sicherstellen }
  1024.       rexxport^.mp_Node.ln_Name := portname;
  1025.       AddPort(rexxport);  { Port öffentlich bekanntgeben }
  1026.       Permit;
  1027.     END;
  1028.     replyport := CreateMsgPort;  { der ist privat }
  1029.   END;
  1030. END;
  1031.  
  1032. FUNCTION privateer{: Integer};
  1033. { Versucht, den PubScreen wieder als privat zu erklären, und stellt fest, }
  1034. { ob das Programm anschließend beendet werden kann. Rückgabewerte: }
  1035. { 0: OK, sysclean darf aufgerufen werden }
  1036. { 1: Fehler, Pubscreen ist noch in Benutzung }
  1037. { 2: Fehler, eins unserer ARexx-Skripts läuft noch }
  1038. BEGIN
  1039.   IF scriptmess<>Nil THEN
  1040.     privateer := 2
  1041.   ELSE IF (PubScreenStatus(MyScreen, PSNF_PRIVATE) AND 1)=0 THEN
  1042.     privateer := 1
  1043.   ELSE
  1044.     privateer := 0;
  1045. END;    
  1046.  
  1047. PROCEDURE sysclean;
  1048. { Vorher muß privateer aufgerufen worden sein, und zwar erfolgreich! }
  1049. { Sonst hinterläßt das Programm einen herrenlosen PubScreen oder einen }
  1050. { ARexx-Prozeß ohne Fenster und Replyport. %-( }
  1051. BEGIN
  1052.   IF myprocess<>Nil THEN
  1053.     myprocess^.pr_WindowPtr := oldwindowptr;
  1054.   IF MyWindow<>Nil THEN BEGIN
  1055.     IF Strip<>Nil THEN BEGIN 
  1056.       ClearMenuStrip(MyWindow); FreeMenus(Strip);
  1057.     END;
  1058.     CloseWindow(MyWindow);
  1059.   END;
  1060.   IF MyScreen<>Nil THEN BEGIN
  1061.     FreeVisualInfo(visinfo);
  1062.     IF CloseScreen(MyScreen) THEN;
  1063.   END;
  1064.   IF rexxport<>Nil THEN BEGIN
  1065.     Forbid;
  1066.     IF rxm=Nil THEN
  1067.       rxm := p_RexxMsg(GetMsg(rexxport));
  1068.     WHILE rxm<>Nil DO BEGIN  { ausstehende Messages "beantworten" }
  1069.       rxm^.rm_Result1 := 10;
  1070.       rxm^.rm_Result2 := 0;
  1071.       ReplyMsg(p_Message(rxm));
  1072.       rxm := p_RexxMsg(GetMsg(rexxport));
  1073.     END;
  1074.     RemPort(rexxport); { Port abmelden }
  1075.     Permit;
  1076.     DeleteMsgPort(rexxport);
  1077.   END;
  1078.   IF replyport<>Nil THEN DeleteMsgPort(replyport);
  1079.   IF teleFont<>Nil THEN CloseFont(teleFont);
  1080.   IF BusyPointerData<>Nil THEN FreeMem(BusyPointerData,SizeOf(WordArr36));
  1081.   IF IntuitionBase<>Nil THEN CloseLibrary(IntuitionBase);
  1082.   IF GfxBase<>Nil THEN CloseLibrary(GfxBase);
  1083.   IF DiskFontBase<>Nil THEN CloseLibrary(DiskFontBase);
  1084.   IF IconBase<>Nil THEN CloseLibrary(IconBase);
  1085.   IF AslBase<>Nil THEN CloseLibrary(AslBase);
  1086.   IF GadToolsBase<>Nil THEN CloseLibrary(GadToolsBase);
  1087.   IF RexxSysBase<>Nil THEN CloseLibrary(RexxSysBase);
  1088.   { festhalten, daß alles geschlossen ist: }
  1089.   IntuitionBase := Nil; GfxBase := Nil; DiskFontBase := Nil;
  1090.   IconBase := Nil; AslBase := Nil; GadToolsBase := Nil; 
  1091.   RexxSysBase := Nil; rexxport := Nil; replyport := Nil;
  1092.   MyScreen := Nil; MyWindow := Nil; Strip := Nil; teleFont := Nil;
  1093.   myprocess := Nil; BusyPointerData := Nil; 
  1094. END;
  1095.  
  1096. VAR i: Integer;
  1097.  
  1098. BEGIN  { Initialisierungsteil }
  1099.   { RGB-Anteile der Farben in der Reihenfolge sw,rt,gn,gb,bl,vl,cn,ws: }
  1100.   palette[0] := $000; palette[1] := $F00; palette[2] := $0F0;
  1101.   palette[3] := $FF0; palette[4] := $00F; palette[5] := $F0F;
  1102.   palette[6] := $0FF; palette[7] := $FFF;
  1103.   colperm := $60712345;
  1104.   screenmode := HIRES; fontno := 1;
  1105.   datestyle := FORMAT_CDN;
  1106.   clip_open := False;
  1107.   lastmsg.seconds := 0; nextselect := MENUNULL;
  1108.   newevent := False; mouseclicked := False; menupicked := False; taste := #0;
  1109.   rexxzeile := ''; rxm := Nil; { <>Nil bedeutet, Antwort steht noch aus !!! }
  1110.   scriptmess := Nil; { <>Nil bedeutet, ein externes Skript läuft noch }
  1111.   rexxpath := 'rexx/';
  1112.   rxscripts := 0;
  1113.   silentrexx := False;
  1114. END.
  1115.  
  1116.