Offene Funktionsbibliothek

---

splitstring()

Ein String 's' wird mittels Trenner 'trenner' in Teilstücke zerlegt.
Die Teile werden im Array 'ergebnis' abgelegt.

Der Rückgabewert ist die Anzahl der Teilstücke.
Beispiel:

var erg : String[]
var anz : integer = splitstring('ein/geteilter/string','/',erg)




==========================================================================
Procedure splitstring(s : String; trenner : String; Var ergebnis : String[]):integer
==========================================================================

  Var anz , a1: Integer = Scan(trenner,s)+1
  Var posi : Integer
  Var i : Integer = -1

  InitArray(ergebnis[anz])
  While  anz-->=0 Do
      posi := Pos(trenner,s)
      ergebnis[i++] := s[1,posi-1]
      s:=s[posi+1,255]
  End

return a1
ENDPROC

---

dbtoxml()

Selektionsergebnis in eine XML-Datei schieben zur weiteren Verarbeitung mit XSLT o.ä.
datname: Datenbankname
suche: Selektion
sortierung: name der Indexdatei zum Sortieren
datout: XML-Ausgabedatei



===========================================================
procedure dbtoxml(datname, suche,sortierung, datout : string)
===========================================================

var i : integer:=0
var db : integer = dbopen(datname)
var out : integer = REWRITE(datout,0)
var f : string
var j : string[]

PRIMTABLE(db)
access(db,sortierung)
writeln(out,'')
sub _DBNAME(db)+', '+suche
i:=0
writeln(out,'')
while i++<=maxlabel(db) do
splitstring(getstructure(db,i),',',j)
write(out,'<'+LABEL(db,i)+' t="'+j[1]+'"')
if HIGH(1,j)>1 then
write(out,' l="'+j[2]+'"')
end
if HIGH(1,j)>2 then
write(out,' nk="'+j[3]+'"')
end
write(out,' >')
f := (getfield(db,i))
if getstructure(db,i) like '*NUMBER*' then
f:= exchange(f,'.',',')
end
f:=exchange(f,'&','+')
f:=exchange(f,'<','<')
f:=exchange(f,'>','>')
write(out,(f))
write(out,'')
end
writeln(out,'')
endsub
writeln(out,'')
CLOSEDB(db)
CLOSE(out)

endproc

---

encodehex()

Wandelt eine ANSI-Datei in einen HEX-Code um.
'source' und 'dest' bezeichnen Dateinamen.

=====================================================
procedure encodehex(source : string;dest : string)
=====================================================
var hex : string = "0123456789ABCDEF"
var bh,bl : integer
var b : string

var d : integer = reset(source,1);

var d1 : integer = rewrite(dest,0);
While not eot(d) do

b:=read(d,1)
bh := asc(b) div 16
bl := asc(b) mod 16

  	Write(d1,hex[bh+1])
  	Write(d1,hex[bl+1])

End
close(d1)
close(d)

endproc

---

decodehex()

Wandelt eine in HEX codierte Datei wieder in ihre ursprüngliche Form
'source' und 'dest' bezeichnen Dateinamen

=====================================================
procedure decodehex(source : string;dest : string)
=====================================================
var hex : string = "0123456789ABCDEF"
var bh,bl : string
var b : integer

var d : integer = reset(source,0);

var d1 : integer = rewrite(dest,1);
While not eot(d) do
bh:=read(d,1)
bl:=read(d,1)
b := (POS(upper(bh),hex) - 1)*16+(POS(upper(bl),hex) - 1)

  	Write(d1,chr(b))

End
close(d1)
close(d)

endproc

---

isNumber()

Prüft, ob ein String eine gültige Zahl darstellt.

procedure isNumber(s:string):integer
/*
Prüft ob es sich bei s um eine gültige Zahl handelt
*/
var p : integer = 0
var b : integer = 1
var m : integer = Length(s)
var c : string = "0123456789."

	while p++<=m,b:=Pos(s[p],c) do end
	return b

endproc

---

rMakeDir()

Legt einen Verzeichnisbaum (z.B. rMakeDir("/var/tdbengine/temp/data/"))an

procedure rMakeDir(sPath:STRING)
/*
Rekursives MakeDir
Legt einen ganzen Verzeichnisbaum an, wenn er nicht bereits existiert
*/

	var sPre  : STRING
	var sPart : STRING
	var p     : INTEGER

	if !IsFile(sPath) then
		if RightStr(sPath,1)#"/" then
			sPath := sPath +"/"
		end
		p:=Pos("/",sPath)
		if sPath[1,p] = "../" or sPath[1,p] = "./" or sPath[1,p] = "/" then
			sPre := sPath[1,p]
			sPath := sPath[p+1,255]
		end
		while p:=Pos("/",sPath) do
			sPart := sPath[1,p]
			MakeDir(sPre+sPart)
			sPre := sPre + sPart
			sPath := sPath[p+1,255]
		end
	end
endproc

---

rfcDateStr()

Generiert einen RFC822-konformen Datumsstring aus einer UNIX_TIMESTAMP. Ideal für Cookie-Expiration-Angaben.

procedure rfcDateStr(iSeconds  : INTEGER) : string
/*
Generiert einen Datumsstring, wie in RFC 822 definiert, jedoch ohne Zeitzonen-Angabe am Ende
Sunday, 01-Dec-2099 12:00:00
*/
	var s 		: STRING
	Var sD, sM 	: STRING
	var iD		: INTEGER

	iD := UNIX_Date(iSeconds)
	s := Choice( 1+(iD+5) MOD 7,"Sunday","Monday","Tuesday","Wednesday","Thursday","Friday","Saturday")+", "
	s := s + Str(Day(iD),2,0,"","0") +"-"
	s := s + Choice(Month(iD)+1,"Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct","Nov","Dec") + "-"
	s := s + Str(Year(iD)) +" "+TimeStr(UNIX_Time(iSeconds),0)
	return s
endproc