' Diverse n�tzliche Routinen f�r... / Some useful routines in...
' ...GFA-BASIC 3.X
'
' von/by Gregor Duchalski, Baueracker 15a,
' W-4690 Herne 1 (ab 1.7.93: 44628 Herne), Germany
' eMail: GREGOR DUCHALSKI @ DO im Mausnetz
'        Gregor Duchalski@do.maus.de
'
' last change 16.03.93
'
' ------------------------------------------------------------------------------
' Ermittelt, ob das Programm im Interpreter (FALSE)
' oder compiliert (TRUE) gestartet wurde...
DEFFN comp=BYTE{ADD(BASEPAGE,256)}<>96   ! Compiled?
' ------------------------------------------------------------------------------
' Ergibt TRUE, wenn das Programm als ACC gestartet wurde...
DEFFN acc=({ADD(BASEPAGE,36)}=0)         ! An ACC?
' ------------------------------------------------------------------------------
' Ergibt TRUE, wenn das Programm unter MultiTOS l„uft...
DEFFN mtos=INT{ADD({ADD(GB,4)},2)}<>1    ! Multitasking TOS?
' ------------------------------------------------------------------------------
' Ersetzt den GFA-VSYNC-Befehl...
> PROCEDURE vsync                        ! Replacement for VSYNC
  a%=XBIOS(2)+31250
  REPEAT
  UNTIL BYTE{&HFF8205}*65536+BYTE{&HFF8207}*256+BYTE{&HFF8209}<a%
  REPEAT
  UNTIL BYTE{&HFF8205}*65536+BYTE{&HFF8207}*256+BYTE{&HFF8209}>a%
RETURN
' ------------------------------------------------------------------------------
' Schaltet die Systemfehler-Routinen aus bzw. ein...
> PROCEDURE alerts_off                   ! System-Alerts off
  INLINE noalert%,8
  {noalert%}=&H4CAF0001       ! eigentlicher Maschinencode : movem.w   $4(a7),d0
  {noalert%+4}=&H44E75        !                              rts
  IF {BASEPAGE+256}<>noalert% ! Um Alertbox nur einmal auszuschalten
    {BASEPAGE+256}=LPEEK(1028)! alten Wert von CEH merken
    SLPOKE 1028,noalert%      ! neue Routine installieren
  ENDIF
RETURN
> PROCEDURE alerts_on                    ! System-Alerts on
  IF BYTE{BASEPAGE+256}=0     ! Alertbox nur anschalten, wenn ausgeschaltet war
    SLPOKE 1028,{BASEPAGE+256}! alte Adresse restaurieren
    {BASEPAGE+256}=-1         ! Einschaltung kennzeichnen
  ENDIF
RETURN
' ------------------------------------------------------------------------------
' Testet, ob der Drucker eingeschaltet ist (TRUE)...
DEFFN online=BIOS(8,0)                   ! Printer online?
' ------------------------------------------------------------------------------
' Tastatur-Puffer l”schen...
LPOKE XBIOS(14,1)+6,0                    ! Clear keyboard-puffer
' ------------------------------------------------------------------------------
' GEM-Puffer l”schen...
> PROCEDURE clr_message                  ! Wait for NO message-event
  '
  WHILE BTST(EVNT_MULTI(&X110000,0,0,0,0,0,0,0,0,0,0,0,0,0,0,3),4)
  WEND
  '
RETURN
> PROCEDURE clr_key                      ! Wait for NO keyboard-event
  '
  WHILE BTST(EVNT_MULTI(&X100001,0,0,0,0,0,0,0,0,0,0,0,0,0,0,50),0)
  WEND
  '
RETURN
> PROCEDURE clr_button                   ! Wait for NO button-event
  LOCAL a&,mb&
  '
  REPEAT
    ~EVNT_MULTI(&X100010,256+1,3,0,0,0,0,0,0,0,0,0,0,0,0,1,a&,a&,mb&,a&,a&,a&)
  UNTIL mb&=0
  '
  WHILE BTST(EVNT_MULTI(&X100010,1,1,1,0,0,0,0,0,0,0,0,0,0,0,3),1)
  WEND
  '
  WHILE BTST(EVNT_MULTI(&X100010,1,2,2,0,0,0,0,0,0,0,0,0,0,0,3),1)
  WEND
  '
RETURN
' ------------------------------------------------------------------------------
' Tos-Version und -Datum ermitteln...
> FUNCTION tos_version$                  ! Inquiring TOS-version
'
a%=LPEEK(&H4F2)
a$=CHR$(ADD(48,PEEK(ADD(a%,2))))+"."+CHR$(ADD(48,PEEK(ADD(a%,4))))+CHR$(ADD(48,PEEK(ADD(a%,3))))
'
RETURN a$
ENDFUNC
> FUNCTION tos_datum$                    ! Inquiring TOS-date
'
a%=LPEEK(&H4F2)
'
a$=CHR$(48+SHR(PEEK(a%+&H19),4))
a$=a$+CHR$(48+(PEEK(a%+&H19) AND &HF))
a$=a$+"."+CHR$(48+SHR(PEEK(a%+&H18),4))
a$=a$+CHR$(48+(PEEK(a%+&H18) AND &HF))
a$=a$+"."+CHR$(48+SHR(PEEK(a%+&H1A),4))
a$=a$+CHR$(48+(PEEK(a%+&H1A) AND &HF))
a$=a$+CHR$(48+SHR(PEEK(a%+&H1B),4))
a$=a$+CHR$(48+(PEEK(a%+&H1B) AND &HF))
'
RETURN a$
ENDFUNC
' ------------------------------------------------------------------------------
' BASEPAGE-Adresse des aktuellen Prozesses...
> FUNCTION act_pd                        ! BASEPAGE of actual process
$F%
LOCAL a&,os%,a%
'
' Ermittelt _sauber_ die Adresse der Basepage des aktiven Prozesses...
'
os%=LPEEK(&H4F2)              ! os_header
os%={ADD(os%,8)}              ! os_beg
a&=INT{ADD(os%,2)}            ! os_version
'
IF a&<&H102                   ! TOS 1.00...
'
a&=SHR(INT{ADD(os%,&H1C)},1)! os_conf
'
IF a&=4                     ! Spanisches TOS...
a%={&H873C}
'
ELSE                        ! Jedes andere...
a%={&H602C}
'
ENDIF
'
ELSE                          ! Ab TOS 1.02...
a%={{ADD(os%,&H28)}}        ! ...direkt auslesen
ENDIF
'
RETURN a%
ENDFUNC
' ------------------------------------------------------------------------------
' Auff�llen mit Nullen...
> FUNCTION format$(a,a&)
LOCAL a$,b&
a$=STR$(a)+STRING$(SUCC(a&),"0")
b&=INSTR(a$,".")
RETURN LEFT$(a$,b&)+LEFT$(RIGHT$(a$,SUB(LEN(a$),b&))+"00",a&)
ENDFUNC
' ------------------------------------------------------------------------------
' F�hrt einen Kalt- oder Warmstart aus...
> PROCEDURE kaltstart                    ! Coldboot
'
~GEMDOS(&H20,L:0)
'
SLPOKE &H420,0
SLPOKE &H426,0
SLPOKE &H43A,0
'
a%=LPEEK(&H4F2)+4
a%=LPEEK(a%)
'
CALL a%
'
RETURN
> PROCEDURE warmstart                    ! Warmboot
'
~GEMDOS(&H20,L:0)
'
a%=LPEEK(&H4F2)+4
a%=LPEEK(a%)
'
CALL a%
'
RETURN
' ------------------------------------------------------------------------------
' Gibt die an das Programm �bergebene Kommandozeile zur�ck...
' Die Eintr„ge sind durch Spaces getrennt."
> FUNCTION kommando$                     ! Get commandline
LOCAL a|
'
a|=BYTE{ADD(BASEPAGE,128)}
'
IF a|
RETURN CHAR{ADD(BASEPAGE,129)}
'
ENDIF
'
RETURN ""
ENDFUNC
' ------------------------------------------------------------------------------
' Hilfreich beim Kopieren vom INLINE in einen String. šbergeben wird die
' INLINE-Adresse und die L„nge...
> FUNCTION inline$(a%,a&)
LOCAL a$
'
a$=SPACE$(a&)
BMOVE a%,V:a$,a&
'
RETURN a$
ENDFUNC
' ------------------------------------------------------------------------------
' Rettet die Farb-Register bzw. restauriert sie...
> PROCEDURE save_register                ! Saving color-registers
original_reg$=SPACE$(32)
FOR i&=0 TO 15
CARD{V:original_reg$+i&*2}=XBIOS(7,i&,-1)
NEXT i&
RETURN
> PROCEDURE restore_register             ! Restoring color-registers
~XBIOS(6,L:V:original_reg$)
RETURN
' ------------------------------------------------------------------------------
' Ersetzt den unsauberen SETMOUSE...
> PROCEDURE setmouse(x&,y&)              ! Replacing the original SETMOUSE
LOCAL a%,a$
'
a%=OR(y&,SHL(x&,16))   !X/Y-Pos. des Mauszeigers
a$=MKL$(2)+MKL$(a%)    !Ereignis
'
GINTIN(0)=1            !Anzahl Ereignisse
GINTIN(1)=100          !Geschwindigkeit in %
ADDRIN(0)=V:a$         !Adresse der Ereignisse
GEMSYS 14              !APPL_TPLAY()
'
RETURN
' ------------------------------------------------------------------------------
' Setzt das Bit b& in a& in Abh„ngigkeit von c&...
DEFFN bsc(a&,b&,c&)=-MUL((c&=0),BCLR(a&,b&))-MUL((c&<>0),BSET(a&,b&))
' ------------------------------------------------------------------------------
' Aufruf einer Shell (hier: Mupfel) �ber den shell_p-vektor...
> FUNCTION shell_call(a$)
$F%
LOCAL a%,b%
'
' R�ckgabe: -1 Keine Shell
'            1 MUPFEL
'            0 Andere Shell
'
a%=LPEEK(&H4F6)                      ! Shell-Einsprungsdresse
'
IF a%                                ! Vorhanden...
'
' a$=MKL$({SUB(a%,12)})+MKL$({SUB(a%,8)})
' a$="XBRAGMNI" OR a$="XBRAMUPF"   ! Mupfel-Identifizierung
'
a$=a$+CHR$(0)                      ! Kommando+Nullbyte
'
b%=C:a%(L:V:a$)                    ! Kommando �bergeben
'
ENDIF
'
RETURN b%
ENDFUNC
' ------------------------------------------------------------------------------
' ##############################################################################
' ########################### STRING-MANIPULATIONEN ############################
' ##############################################################################
' ------------------------------------------------------------------------------
' Gibt den ersten Teil eines durch '|' abgeteilten Strings zur�ck und
' verk�rzt den Originalstring...
' Beispiel: a$="ABC|DEF" ==> @teil$(a$)="ABC"; a$="DEF"
> FUNCTION teil$(VAR a$)
LOCAL b$,a&
a&=INSTR(a$,"|")
IF a&
b$=LEFT$(a$,PRED(a&))
a$=MID$(a$,SUCC(a&))
ELSE
b$=a$
a$=""
ENDIF
RETURN b$
ENDFUNC
' ------------------------------------------------------------------------------
' F�gt in den String b$ den String a$ an der Position a& ein...
> PROCEDURE insert(a$,a&,VAR b$)
LOCAL c$
c$=LEFT$(b$,PRED(a&))
c$=c$+a$+MID$(b$,a&)
b$=c$
RETURN
' ------------------------------------------------------------------------------
' L”scht in a$ ab Position a& 'b&'-Zeichen...
> PROCEDURE delete(a&,b&,VAR a$)
LOCAL c$
c$=LEFT$(a$,PRED(a&))
c$=c$+MID$(a$,a&+b&)
a$=c$
RETURN
' ------------------------------------------------------------------------------
' Ersetzen in einem String...
' Ersetzt in a$ ab Position a& 'b&'-positionen durch b$...
> PROCEDURE replace(a&,b&,b$,VAR a$)
c$=LEFT$(a$,PRED(a&))
c$=c$+b$+MID$(a$,a&+b&)
a$=c$
RETURN
' ------------------------------------------------------------------------------
' Abschneiden der Leerzeichen am linken bzw. rechten Rand eines Strings...
> FUNCTION ltrim$(a$)
FOR i&=1 TO LEN(a$)
IF MID$(a$,i&,1)=" "
INC pos&
ELSE
i&=LEN(a$)
ENDIF
NEXT i&
a$=RIGHT$(a$,SUB(LEN(a$),pos&))
RETURN a$
ENDFUNC
> FUNCTION rtrim$(a$)
pos&=LEN(a$)
FOR i&=LEN(a$) DOWNTO 1
IF MID$(a$,i&,1)=" "
DEC pos&
ELSE
i&=1
ENDIF
NEXT i&
a$=LEFT$(a$,pos&)
RETURN a$
ENDFUNC
' ------------------------------------------------------------------------------
' Suchen in einem eindimensionalen Stringfeld : von,bis,feld,such$...
> FUNCTION instr(a&,b&,VAR a$(),b$)
IF b&>PRED(DIM?(a$()))
ALERT 3," | Funktion INSTR nicht | durchf�hrbar! ",1,"Abbruch",b&
ELSE
IF a&=-1
a&=1
b&=PRED(DIM?(a$()))
ENDIF
FOR i&=a& TO b&
IF a$(i&)=b$
RETURN i&
ENDIF
NEXT i&
ENDIF
RETURN -1
ENDFUNC
' ------------------------------------------------------------------------------
' Sucht den String 'find$' an der Adresse 'adr%' im Speicherbereich mit
' der L„nge 'l%'...
> FUNCTION find_string(find$,adr%,l%)       ! Search a string
$F%
LOCAL len&,a&,a%,a$
'
' last change 14.04.93
'
len&=MIN(l%,4100)                       ! L„nge des Teilstrings
a$=STRING$(len&,0)                      ! Teilstring
'
a%=adr%                                 ! Startadresse
end%=ADD(adr%,PRED(l%))                 ! Endadresse
'
DO WHILE ADD(a%,len&)<end%
'
BMOVE a%,V:a$,len&
ADD a%,len&
'
a&=INSTR(a$,find$)
'
LOOP UNTIL a&
'
rest&=SUB(end%,PRED(a%))
'
IF a&=0 AND rest&>0
BMOVE a%,V:a$,rest&
ADD a%,len&
'
a&=INSTR(a$,find$)
ENDIF
'
IF a&
RETURN a%-len&+PRED(a&)
ENDIF
'
RETURN 0
ENDFUNC
' ------------------------------------------------------------------------------
' Blocksatz...
> FUNCTION blocksatz$(a$,a&)
LOCAL b&,c&
b&=1
c&=a&-LEN(a$)
WHILE c&>0
b&=INSTR(a$," ",b&)
IF b&=0
b&=1
b&=INSTR(a$," ",b&)
ENDIF
a$=LEFT$(a$,b&)+" "+RIGHT$(a$,LEN(a$)-b&)
ADD b&,2
DEC c&
WEND
RETURN a$
ENDFUNC
' ------------------------------------------------------------------------------
' F�gt in eine Zahl die Dezimalpunkte ein (z.B. 1234="1.234")...
> FUNCTION dez.pkt$(a%)
LOCAL a$,b$,i&
'
a$=STR$(a%)
b$=""
'
FOR i&=LEN(a$)-3 TO 1 STEP -3
b$="."+MID$(a$,SUCC(i&),3)+b$
NEXT i&
'
b$=LEFT$(a$,(i&+3))+b$
'
RETURN b$
ENDFUNC
' ------------------------------------------------------------------------------
' F�gt in eine Zahl a& Nullen ein, bis L„nge b& erreicht...
DEFFN null$(a&,b&)=RIGHT$(STRING$(b&,"0")+STR$(a&),b&)
' ##############################################################################
' ############################## DISK-OPERATIONEN ##############################
' ##############################################################################
' ------------------------------------------------------------------------------
' šberpr�ft/Setzt das FASTLOAD-Flag im Programmheader (1=an/0=aus)...
> FUNCTION check_fastload(a$)
'
a%=0
'
OPEN "U",#1,a$
SEEK #1,&H16
BGET #1,V:a%,4
CLOSE #1
'
RETURN -a%
ENDFUNC
> PROCEDURE set_fastload(a$,a%)
'
a%=ABS(a%)
'
OPEN "U",#1,a$
SEEK #1,&H16
BPUT #1,V:a%,4
'
CLOSE #1
'
RETURN
' ------------------------------------------------------------------------------
' Ermittelt die Datei-Infos...
> FUNCTION get_fileinfo(datei$,VAR datum$,uhr$,laenge%)
LOCAL a|,a&,b&,f&
LOCAL sek|,min|,std|,tag|,mon|,jhr&
'
f&=FSFIRST(datei$,0)           ! Datei suchen...
'
IF f&=0                        ! ...gefunden
'
a|=BYTE{BASEPAGE+128+21}     ! Attribute
a&=WORD{BASEPAGE+128+22}     ! Uhrzeit
b&=WORD{BASEPAGE+128+24}     ! Datum
laenge%={BASEPAGE+128+26}    ! L„nge
'
sek|=(a& AND &X11111)*2
min|=SHR(a&,5) AND &X111111
std|=SHR(a&,11) AND &X11111
'
uhr$=@null$(std|,2)+":"+@null$(min|,2)+":"+@null$(sek|,2)
'
tag|=b& AND &X11111
mon|=SHR(b&,5) AND &X1111
jhr&=(SHR(b&,9) AND &X11111)+1980
'
datum$=@null$(tag|,2)+"."+@null$(mon|,2)+"."+@null$(jhr&,4)
'
RETURN TRUE
ENDIF
'
RETURN FALSE
ENDFUNC
' ------------------------------------------------------------------------------
' Testet, ob die Datei Schreibgesch�tz ist...
' -1: ja, -33: nicht gefunden, 0: gefunden und nicht protected
> FUNCTION protected(a$)
LOCAL a&,a|
'
a&=FSFIRST(a$,0)               !Datei suchen...
'
IF a&=0                        !...Gefunden
a|=BYTE{BASEPAGE+128+21}
RETURN BTST(a|,0)            !Schreibschutz gesetzt
ENDIF
'
RETURN a&
ENDFUNC
' ------------------------------------------------------------------------------
' Kopiert eine Datei: copy(source$,dest$)...
> PROCEDURE copy(a$,b$)
LOCAL a%,b%,c%,i%
b%=1
IF EXIST(b$)
ALERT 3," | Datei existiert bereits... ",1,"Weiter|Abbruch",b%
ENDIF
IF b%=1
OPEN "I",#1,a$         !Quell-File
OPEN "O",#2,b$         !Ziel-File
a%=LOF(#1)             !L„nge des Files
b%=FRE(0)-3000         !Freier Speicher
c%=a% MOD b%           !Rest
DIM a|(b%)             !Speicher reservieren
FOR i%=1 TO (a% DIV b%)!Solange alles lesen bis Rest zu klein
BGET #1,V:a|(0),b%   !Lesen
BPUT #2,V:a|(0),b%   !Schreiben
NEXT i%
BGET #1,V:a|(0),c%     !Rest lesen
BPUT #2,V:a|(0),c%     !Rest schreiben
CLOSE
ERASE a|()
ENDIF
RETURN
' ------------------------------------------------------------------------------
' Disknamen lesen und schreiben...
> FUNCTION get_label$(a&)
CHDRIVE a&
~FSETDTA(BASEPAGE+128)                        ! DTA setzen
a%=FSFIRST("*.*",8)                           ! nur DISKNAME lesen
a$=CHAR{BASEPAGE+158}                         ! D_NAME lesen
IF a%=-33                                     ! wenn kein DISKNAME auf Disk
a$=""                                       ! A$ auf Leerstring setzen
ENDIF
RETURN a$
ENDFUNC
> PROCEDURE set_label(a&,a$)
CHDRIVE a&
a$=LEFT$(a$,8)+CHR$(0)              ! dem Namen Nullbyte anh„ngen
a%=GEMDOS(60,L:V:a$,8)              ! Datei anlegen
IF a%>0                             ! wenn Datei angelegt
~GEMDOS(62,a%)                    ! Datei schliežen
~GEMDOS(67,L:V:a$,1,8)            ! Datei in DISKNAMEN umbennen
ENDIF
RETURN
' ------------------------------------------------------------------------------
' Erweiterte ~FSEL_INPUT Routine ab TOS 1.04...
> FUNCTION fsel_exinput(a$,VAR b$,c$)
'
a$=a$+CHR$(0)
b$=b$+CHR$(0)+SPACE$(40)
c$=c$+CHR$(0)+SPACE$(15)
'
GCONTRL(0)=91
GCONTRL(1)=0
GCONTRL(2)=2
GCONTRL(3)=3
GCONTRL(4)=0
'
ADDRIN(0)=V:b$
ADDRIN(1)=V:c$
ADDRIN(2)=V:a$
'
GEMSYS
'
RETURN GINTOUT(1)
ENDFUNC
' ------------------------------------------------------------------------------
' Ermittelt den aktuellen Pfad...
pfad$=CHR$(GEMDOS(25)+65)+":"+DIR$(0)+"\"
' ------------------------------------------------------------------------------
' Blinken der Laufwerkslampen...
' a&=Laufwerk 1 oder 2, b&=Wie oft blinken, c&=L„nge des Blinkens
> PROCEDURE drive_blink(a&,b&,c&)
FOR i&=1 TO b&
~XBIOS(29,5-a&)
PAUSE c&
~XBIOS(30,2+a&)
PAUSE c&
NEXT i&
RETURN
' ------------------------------------------------------------------------------