' XML-Parser v110803

'shipped with patfinder (http://www.freebasic-portal.de/projekte/patfinder-41.html)
'and made by nemored

#define leerzeichen  32
#define quoteDoppelt 34
#define quoteEinfach 39
#define slash        47
#define klammerAuf   60
#define klammerZu    62

Type TypXML
  As String tag,       _  ' Name des ersten auffindbaren Tags
            attribute, _  ' enthaelt alle Attribute
            inhalt,    _  ' alles innerhalb des Tags; kann weitere Tags enthalten
            vorspann,  _  ' alles vor dem ersten auffindbaren Tag
            rest,      _  ' alles nach dem Schliesstag; kann weitere Tags enthalten
            fehler        ' Fehlermeldung, falls ein Fehler auftrat; sonst leer
  ' GetAttr liest den Inhalt des angegebenen Attributs
  ' existiert das Attribut nicht, dann wird ein Leerstring zurueckgegeben
  ' Es findet keine Zwischenspeicherung statt; GetAttr sollte je Tag und Attribut nur einmal aufgerufen werden.
  Declare Function GetAttr(attr As String) As String
End Type

Declare Sub xmlBaum(daten As String, ebene As Integer = 0)
Declare Function xmlErsetzung(eingabe As String, original As String, ersetzung As String) As String
Declare Function xmlParse (eingabe As String = "", datei As Integer = 0) As TypXML
Declare Function TypXML_suchestring(eingabe As String, suchstring As String, datei As Integer, _
                            ueberspringeTag As String = "") As TypXML


Sub xmlBaum(daten As String, ebene As Integer = 0)
  ' zeigt eine Baumstruktur der Tags einer Datei an
  ' Beim Aufruf enthaelt 'daten' den Dateinamen, 'ebene' wird leer gelassen.
  Dim As TypXML tempxml
  If ebene = 0 Then
    Dim As Integer f = FreeFile
    Open daten For Input As #f
    tempxml = xmlParse(, f)
    Close #f
  Else
    tempxml = xmlParse(daten)
  End If
  If tempxml.fehler <> "" Then Print "*** FEHLER: " & tempxml.fehler & " ***"
  Do
    If Trim(tempxml.vorspann) <> "" Then Print Space(ebene*2); tempxml.vorspann
    If tempxml.tag = "" Then Exit Sub
    Print Space(ebene*2); "<"; tempxml.tag; tempxml.attribute; ">"
    xmlBaum(tempxml.inhalt, ebene+1)
    Print Space(ebene*2); "</"; tempxml.tag;">"
    ' Rest bis zur naechsten Spitzklammer anzeigen
    Dim rest As String = Trim(tempxml.rest), such As Integer = InStr(rest, "<")
    If such > 1 Then
      Print Space(ebene*2); Trim(Left(tempxml.rest, such-1))
    ElseIf such <> 1 And rest <> "" Then
      Print Space(ebene*2); rest
    End If
    tempxml = xmlParse(tempxml.rest)
  Loop Until tempxml.tag = ""
End Sub

Function xmlErsetzung(eingabe As String, original As String, ersetzung As String) As String
  ' ersetze in 'eingabe' den Teilstring 'original' durch 'ersetzung'
  Dim z As Integer, ret As String = eingabe
  Do
    z = InStr(ret, original)
    If z = 0 Then Exit Do
    ret = Left(ret, z-1) & ersetzung & Mid(eingabe, z+Len(original))
  Loop
  Return ret
End Function

Function xmlParse(eingabe As String = "", datei As Integer = 0) As TypXML
  Dim ret As TypXML, tempxml As TypXML, tempstring As String = eingabe
  Dim As Integer suche, suche2, tempint, leeresTag
  ' suche nach Verarbeitungsanweisungen <?... ?> und DOCTYPE-Deklaration <!DOCTYPE ... >
  ' (beide werden komplett ignoriert!)
  If tempstring = "" AndAlso Not EOF(datei) Then Line Input #datei, tempstring
  Do
    suche = InStr(tempstring, "<?")
    If suche = 0 Then Exit Do
    tempint = suche + 2
    tempxml = TypXML_suchestring(Mid(tempstring, tempint), "?>", datei)
    If tempxml.fehler <> "" Then
      ret.fehler = "Nicht geschlossene Verarbeitungsanweisung"
      Return tempxml
    End If
    tempstring = Left(tempstring, suche-1) & tempxml.rest
  Loop
  Do
    suche = InStr(tempstring, "<!DOCTYPE")
    If suche = 0 Then Exit Do
    tempint = suche + 9
    tempxml = TypXML_suchestring(Mid(tempstring, tempint), ">", datei)
    If tempxml.fehler <> "" Then
      ret.fehler = "Nicht geschlossene Deklaration"
      Return ret
    End If
    tempstring = Left(tempstring, suche-1) & tempxml.rest
  Loop
  ' suche nach Kommentaren
  Do
    suche = InStr(tempstring, "<!--")
    If suche = 0 Then Exit Do
    tempint = suche + 4
    tempxml = TypXML_suchestring(Mid(tempstring, tempint), "-->", datei)
    If tempxml.fehler <> "" Then
      ret.fehler = "Nicht geschlossener Kommentar"
      Return ret
    End If
    tempstring = Left(tempstring, suche-1) & tempxml.rest
  Loop
  ' suche oeffnende Spitzklammer
  Do
    suche = InStr(tempstring, "<")
    If suche = 0 Then
      ret.vorspann &= tempstring & " "
      If EOF(datei) Then Return ret
      Line Input #datei, tempstring
    Else
      ret.vorspann &= Left(tempstring, suche-1)
      tempstring = Mid(tempstring, suche+1)
      Exit Do
    End If
  Loop
  ' ret.vorspann wurde gefunden; eingabe beginnt nun mit dem ersten XML-Tag
  leeresTag = 0  ' regulaer sind Tags nicht leer
  suche = InStr(tempstring & " ", Any Chr(9) & " >")
  If tempstring[suche-2] = slash Then
    If suche < 4 Then
      ret.fehler = "Unerlaubte Spitzklammer '<'"
      Return ret
    End If
    ret.tag = Mid(tempstring, 1, suche-2)
  Else
    If suche < 3 Then
      ret.fehler = "Unerlaubte Spitzklammer '<'"
      Return ret
    End If
    ret.tag = Mid(tempstring, 1, suche-1)
  End If
  tempstring = Mid(tempstring, suche)
  ' suche zugehoerige schliessende Spitzklammer
  Do
    suche = InStr(tempstring, ">")
    If suche = 0 Then
      ret.attribute &= tempstring & " "
      If EOF(datei) Then
        ret.fehler = "Fehlende Spitzklammer '>'"
        Return ret
      Else
        Line Input #datei, tempstring
      End If
    Else
      If tempstring[suche-2] = slash Then
        leeresTag = -1
        tempstring = Left(tempstring, suche-2) & Mid(tempstring, suche)
        suche -= 1
      End If
      ret.attribute &= Left(tempstring, suche-1)
      tempstring = Mid(tempstring, suche+1)
      Exit Do
    End If
  Loop
  ' suche zugehoerigen End-Tag
  If leeresTag Then
  Else
    tempxml = TypXML_suchestring(tempstring, "</" & ret.tag & ">", datei, ret.tag)
    If tempxml.fehler <> "" Then
      ret.fehler = "Fehlendes End-Tag"
      Return ret
    End If
  End If
  tempstring = Left(tempstring, suche-1) & tempxml.rest
  ret.rest = tempxml.rest
  ret.vorspann = Trim(ret.vorspann)
  ret.attribute = RTrim(ret.attribute)
  ret.inhalt = Trim(tempxml.inhalt)
  Return ret
End Function

Function TypXML.GetAttr(attr As String) As String
  Dim As Integer suche1, suche2, temp
  suche1 = InStr(LCase(this.attribute), " " & LCase(attr) & Chr(61, 34))     ' doppeltes Anfuehrungszeichen
  If suche1 > 0 Then
    temp = suche1 + Len(attr) + 3
    suche2 = InStr(temp, this.attribute, Chr(34))
    If suche2 = 0 Then
      this.fehler = "Fehlendes Anfuehrungszeichen zum Attribut-Ende"
      Return ""
    End If
    Return Mid(this.attribute, temp, suche2-temp)
  Else
    suche1 = InStr(LCase(this.attribute), LCase(attr) & Chr(61, 39))   ' einfaches Anfuehrungszeichen
    If suche1 > 0 Then
      temp = suche1 + Len(attr) + 2
      suche2 = InStr(temp, this.attribute, Chr(39))
      If suche2 = 0 Then
        this.fehler = "Fehlendes Anfuehrungszeichen zum Attribut-Ende"
        Return ""
      End If
      Return Mid(this.attribute, temp, suche2-temp)
    End If
  End If
  this.fehler = "Fehlendes Attribut"
  Return ""
End Function

Function TypXML_suchestring(eingabe As String, suchstring As String, datei As Integer, _
                            ueberspringeTag As String = "") As TypXML
  Dim As TypXML ret
  Dim As Integer suche, suche2, suche3, tempint = 1, tempint2 = 1, tempint3
  Dim As String string1 = eingabe, string2
  Do
    suche = InStr(tempint, string1, suchstring)
    If suche = 0 Then
      If EOF(datei) Then
        ret.fehler = "gesuchten String nicht gefunden"
        Return ret
      End If
      tempint = Len(string1)
      Line Input #datei, string2
      string1 &= string2
    End If
    If ueberspringeTag <> "" Then
      tempint2 = tempint
      Do
        suche2 = InStr(tempint2, string1, "<" & ueberspringeTag)
        If suche2 = 0 Or suche2 > suche Then Exit Do
        Dim As Integer weiter = string1[suche2+Len(ueberspringeTag)]
        If weiter <> leerzeichen And weiter <> slash And weiter <> klammerZu Then
          tempint2 = suche2+Len(ueberspringeTag)
          Continue Do
        End If
        ' Verschachtelung gefunden; diese muss erst aufgelöst werden
        tempint3 = suche2
        ' suche zugehoerige schliessende Spitzklammer
        Do
          suche3 = InStr(tempint3, string1, ">")
          If suche3 = 0 Then
            If EOF(datei) Then
              ret.fehler = "gesuchten String nicht gefunden"
              Exit Do, Do, Do
            Else
              tempint3 = Len(string1)
              Line Input #datei, string2
              string1 &= string2
            End If
          Else
            If string1[suche3-2] <> slash Then
              ' zugehoeriges Endtag suchen
              ret = TypXML_suchestring(Mid(string1, suche3+1), "</" & ueberspringeTag & ">", datei, ueberspringeTag)
              If ret.fehler <> "" Then Exit Do, Do, Do
              tempint = Len(string1) - Len(ret.rest)
            End If
            tempint2 = suche3
          End If
        Loop Until suche3 > 0
        suche = 0  ' alte Suche ist jetzt ungueltig und muss wiederholt werden
      Loop
    End If
  Loop Until suche > 0
  ret.inhalt = Left(string1, suche - 1)
  ret.rest = Mid(string1, suche + Len(suchstring))
  If ret.rest = "" AndAlso Not EOF(datei) Then Line Input #datei, ret.rest
  Return ret
End Function
