VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cGAMPackage"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Public RPAK As cRPakArchive
Public XMLFile As DOMDocument

Public ErrDesc As String
Public ErrSource As String


Public Title As String
Public Version As String
Public ShortDesc As String
Public LongDesc As String

Public AuthorName As String
Public AuthorType As String


Public Dependencies As New Collection

Public snode As IXMLDOMNode


Public RegistrySStructure As New cGAMRegistryNode
Public RegistrySTypes As New CHive

Public Property Get ShortName() As String
ShortName = Mid(RPAK.FileName, InStrRev(RPAK.FileName, "\") + 1)
End Property

Public Function FileOpen(FileName As String, Optional Password As String = "", Optional OverridePassword As Boolean = False, Optional OverrideChildPasswords As Boolean = True) As Boolean
On Error GoTo fehler
Log "Opening Package File '" & FileName & "'...", ltAction

Set RPAK = New cRPakArchive
Set XMLFile = New DOMDocument

Dim xmlstr As String


'Debug.Print FileName

If Not RPAK.FileOpen(FileName, Password, OverridePassword) Then Err.Raise 1001, "RPackage.FileOpen", "Could not Load RPak file: " & RPAK.ErrDesc: Exit Function


xmlstr = RPAK.Root.GetContent("package.xml")
If Not XMLFile.loadXML(xmlstr) Then Err.Raise 10001, "RPackage.FileOpen", "Could not load XML string: " & XMLFile.parseError.reason & vbCrLf & "Line " & XMLFile.parseError.Line & " Pos " & XMLFile.parseError.LinePos & ": " & XMLFile.parseError.srcText
If Not ParseXML(OverridePassword, OverrideChildPasswords) Then Err.Raise 10001, "RPackage.FileOpen", "Could not Parse XML: " & ErrDesc


Log "Success in opening package.", ltSuccess
FileOpen = True

Exit Function
fehler:

If (Err.Description = "Could not Load RPak file: Invalid password.") And (Password = "") Then
    
Else
Debug.Print "Error: " & Err.Description
End If


FileOpen = False
ErrDesc = Err.Description
ErrSource = Err.source
End Function

Public Function FileSave(FileName As String)
Dim x As String
x = BuildXML

Dim fId As Integer
fId = RPAK.Root.FindFile("package.xml")

If fId >= 0 Then
    RPAK.Root.FileContent(fId) = x
    RPAK.FileSave RPAK.FileName
Else
    RPAK.Root.AddFile "package.xml", x

End If

End Function

Private Function BuildXML() As String

Dim XMLDom As New DOMDocument

Dim mainnode As IXMLDOMElement
Set mainnode = XMLDom.createElement("rpackage")
Set XMLDom.documentElement = mainnode


Dim A As IXMLDOMAttribute
Dim n As IXMLDOMElement, n2 As IXMLDOMElement
Dim i As Integer
Dim s As String

Set A = XMLDom.createAttribute("version")
A.Text = PackageFormatMajor & "." & PackageFormatMinor & "." & PackageFormatRevision

mainnode.Attributes.setNamedItem A

'build header
Set n = XMLDom.createElement("header")
mainnode.appendChild n

Set n2 = XMLDom.createElement("title")
    n2.Text = Me.Title
    n.appendChild n2

Set n2 = XMLDom.createElement("version")
    n2.Text = Me.Version
    n.appendChild n2

Set n2 = XMLDom.createElement("shortdesc")
    n2.Text = Me.ShortDesc
    n.appendChild n2
    
Set n2 = XMLDom.createElement("longdesc")
    n2.Text = Me.LongDesc
    n.appendChild n2

Set n2 = XMLDom.createElement("author")
    n2.Text = Me.AuthorName
    
    Set A = XMLDom.createAttribute("type")
        A.Text = Me.AuthorType
        
    n2.Attributes.setNamedItem A
    n.appendChild n2
    
'build dependencies
Set n = XMLDom.createElement("dependencies")
mainnode.appendChild n

For i = 1 To Me.Dependencies.Count
    Set n2 = XMLDom.createElement("dependency")
    Set A = XMLDom.createAttribute("src")
        s = Me.Dependencies(i).RPAK.FileName
        s = Mid(s, InStrRev(s, "\") + 1)
        A.Text = s
        n2.Attributes.setNamedItem A
    
    Set A = XMLDom.createAttribute("checksum")
        A.Text = "1234"
        n2.Attributes.setNamedItem A
        
    n.appendChild n2
Next i

'settings node
Set n = XMLDom.createElement("properties")
    mainnode.appendChild n
Set n2 = XMLDom.createElement("settingsdefinition")
    n.appendChild n2
    BuildSRegistryXML n2, XMLDom, RegistrySStructure
Set n2 = XMLDom.createElement("customtypes")
    n.appendChild n2
    BuildSTypesXML n2, XMLDom, RegistrySTypes


BuildXML = XMLDom.xml
End Function

Private Function BuildSRegistryXML(ByRef XMLElement As IXMLDOMElement, ByRef XMLDom As DOMDocument, ByRef RegistryNode As cGAMRegistryNode)

If LCase(Left(RegistryNode.NodeType, 7)) = "custom:" Then Exit Function

Dim i As Integer, j As Integer
Dim n As IXMLDOMElement, A As IXMLDOMAttribute
Dim rn As cGAMRegistryNode

For i = 1 To RegistryNode.SubElements.Count
    Set rn = RegistryNode.SubElements(i)
    
    'Settings node
    Set n = XMLDom.createElement("setting")
        XMLElement.appendChild n
    
    'Attributes
    For j = 1 To rn.Parameters.Count
    
        Set A = XMLDom.createAttribute(rn.Parameters.Key(j))
            A.Text = rn.Parameters(j)
            n.Attributes.setNamedItem A
    Next j

    
    BuildSRegistryXML n, XMLDom, rn
Next i

End Function

Private Function BuildSTypesXML(XMLElement As IXMLDOMElement, XMLDom As DOMDocument, CTCollection As CHive)
Dim i As Integer
Dim n As IXMLDOMElement, A As IXMLDOMAttribute
Dim ct As cGAMRegistryCustomType

For i = 1 To CTCollection.Count
    Set ct = CTCollection(i)
    Set n = XMLDom.createElement("type")
        XMLElement.appendChild n
    Set A = XMLDom.createAttribute("name")
        A.Text = ct.Name
        n.Attributes.setNamedItem A
    
    BuildSRegistryXML n, XMLDom, ct.PrototypeNode
Next i
End Function

Private Function ParseXML(Optional OverridePassword As Boolean = False, Optional OverrideChildPasswords As Boolean = True) As Boolean
On Error GoTo fehler

Dim doc As IXMLDOMElement
Set doc = XMLFile.documentElement

If Not LCase(doc.tagName) = "rpackage" Then Err.Raise 10001, "RPackage.ParseXML", "Invalid root element: should be rpackage, is '" & doc.tagName & "'"
If Not doc.getAttribute("version") = PackageFormatMajor & "." & PackageFormatMinor & "." & PackageFormatRevision Then Err.Raise 10001, "RPackage.ParseXML", "Invalid version: should be " & PackageFormatMajor & "." & PackageFormatMinor & "." & PackageFormatRevision & " , is '" & doc.getAttribute("version") & "'"

Dim header As IXMLDOMNode
Set header = doc.getElementsByTagName("header")(0)

Title = header.selectNodes("title")(0).Text
Version = header.selectNodes("version")(0).Text
ShortDesc = header.selectNodes("shortdesc")(0).Text
LongDesc = header.selectNodes("longdesc")(0).Text

Dim A As IXMLDOMNode
Set A = header.selectNodes("author")(0)
AuthorName = A.Text
AuthorType = A.Attributes.getNamedItem("type").Text


Set Dependencies = New Collection
Dim deplist As IXMLDOMNodeList
Set deplist = doc.getElementsByTagName("dependencies")(0).selectNodes("dependency")

Dim dn As String
Dim i As Integer
For i = 0 To deplist.Length - 1
    dn = deplist(i).Attributes.getNamedItem("src").Text
    If Not AddDependency(dn, OverrideChildPasswords) Then
        Err.Raise 10001, "cGAMPackage.ParseXML - " & ErrSource, "Could not add dependency '" & dn & "': " & ErrDesc
    End If
Next i
    
    
    
Set snode = doc.getElementsByTagName("properties")(0)

AddCustomTypesStructure snode.selectSingleNode("customtypes")
BuildRegistryStructure RegistrySStructure, snode.selectSingleNode("settingsdefinition")


ParseXML = True
Exit Function
fehler:
ParseXML = False
ErrDesc = Err.Description
ErrSource = Err.source
End Function

Private Function AddCustomTypesStructure(XNode As IXMLDOMNode)
Dim i As Integer
Dim j As Integer
Dim x As IXMLDOMNode
Dim y As IXMLDOMNode
Dim sn As cGAMRegistryNode


Dim ct As cGAMRegistryCustomType

For i = 0 To XNode.childNodes.Length - 1
Set x = XNode.childNodes(i)

    Set ct = New cGAMRegistryCustomType
    
    ct.Name = x.Attributes.getNamedItem("name").Text
    
    BuildRegistryStructure ct.PrototypeNode, x, False
    
    RegistrySTypes.Add ct, LCase(ct.Name)
Next i
End Function

Private Function BuildRegistryStructure(RNode As cGAMRegistryNode, XNode As IXMLDOMNode, Optional UseRecursion As Boolean = True)
    'Erstellt Objektstruktur der Registry und füllt sie mit Standardwerten
    '
    'RNode: Registry-Node des aktuellen Eintrags
    'XNode: XML-Node des aktuellen Eintrags
    
    If XNode Is Nothing Then Exit Function
    
    Dim i As Integer
    Dim x As IXMLDOMNode
    Dim n As cGAMRegistryNode
    
    Dim sDefault As String, sFriendlyName As String, sDescription As String
    Dim sName As String, sNodeType As String
    Dim Params As CHive
    
    
    For i = 0 To XNode.childNodes.Length - 1
        Set x = XNode.childNodes(i)
        If Not x.NodeType = NODE_COMMENT Then
            Set Params = New CHive
            
            
            sName = x.Attributes.getNamedItem("name").Text
            sNodeType = x.Attributes.getNamedItem("type").Text
            
            
            Dim Default As IXMLDOMNode, FriendlyName As IXMLDOMNode, Description As IXMLDOMNode
            
            Set Default = x.Attributes.getNamedItem("default")
            If Not Default Is Nothing Then sDefault = Default.Text
            
            Set FriendlyName = x.Attributes.getNamedItem("friendlyname")
            If Not FriendlyName Is Nothing Then sFriendlyName = FriendlyName.Text
            
            Set Description = x.Attributes.getNamedItem("description")
            If Not Description Is Nothing Then sDescription = Description.Text
            
            
            Dim j As Integer
            For j = 0 To x.Attributes.Length - 1
                Params.Add x.Attributes(j).Text, x.Attributes(j).baseName
            Next j



            Set n = AddRegistryStructureNode(RNode, sName, sNodeType, sDefault, sFriendlyName, sDescription, Params, x)
            

            If UseRecursion Then BuildRegistryStructure n, x
        End If
    Next i
End Function

Public Function AddRegistryStructureNode(ParentNode As cGAMRegistryNode, NodeName As String, NodeType As String, Default As String, FriendlyName As String, Description As String, Optional Parameters As CHive = Nothing, Optional XMLNode As IXMLDOMNode = Nothing, Optional UseRecursion As Boolean = True, Optional FromCollection As CHive = Nothing)
Dim n As New cGAMRegistryNode

n.NodeName = NodeName
n.NodeType = NodeType
n.FriendlyName = FriendlyName
n.Description = Description
n.Value = Default
If Not XMLNode Is Nothing Then Set n.XMLNode = XMLNode
If Not Parameters Is Nothing Then Set n.Parameters = Parameters

If Left(LCase(n.NodeType), 7) = "custom:" Then BuildRegistryStructure_CustomTypeNode n, FromCollection
            

Set n.ParentNode = ParentNode
ParentNode.SubElements.Add n, n.NodeName

Set AddRegistryStructureNode = n
End Function

Public Function BuildRegistryStructure_CustomTypeNode(n As cGAMRegistryNode, Optional FromCollection As CHive = Nothing)
Dim ct As String

If FromCollection Is Nothing Then Set FromCollection = RegistrySTypes

ct = Mid(n.NodeType, 8)

If Not FromCollection.Exist(ct) Then Exit Function
If FromCollection(LCase(ct)) Is Nothing Then Exit Function

Dim CTProto As cGAMRegistryCustomType

Set CTProto = FromCollection(LCase(ct))



    Dim i As Integer, j As Integer
    Dim SE As cGAMRegistryNode
    Dim SEProto As cGAMRegistryNode
    Dim Param As CHive
    
    For i = 1 To CTProto.PrototypeNode.SubElements.Count
        Set SEProto = CTProto.PrototypeNode.SubElements(i)
        Set Param = New CHive
            
        For j = 1 To SEProto.Parameters.Count
            Param.Add SEProto.Parameters(j), SEProto.Parameters.Key(j)
        Next j
        
        AddRegistryStructureNode n, SEProto.NodeName, SEProto.NodeType, SEProto.Value, SEProto.FriendlyName, SEProto.Description, Param, , , FromCollection
        
    Next i


End Function


Public Sub StructureToRegistry(Registry As cGAMRegistryNode, RegistryTypes As CHive)
STypesToTypes RegistryTypes
SRegistryToRegistry Registry
End Sub

Private Sub SRegistryToRegistry(Registry As cGAMRegistryNode)
Dim i As Integer
For i = 1 To RegistrySStructure.SubElements.Count
Registry.SubElements.Add RegistrySStructure.SubElements(i), RegistrySStructure.SubElements.Key(i)
Next i
End Sub

Private Sub STypesToTypes(RegistryTypes As CHive)
Dim i As Integer
For i = 1 To RegistrySTypes.Count
    RegistryTypes.Add RegistrySTypes(i), RegistrySTypes.Key(i)
Next i
End Sub

Public Function AddDependency(deppath As String, Optional OverridePassword As Boolean = False) As Boolean
On Error GoTo fehler

If LCase(deppath) = LCase(ShortName) Then Err.Raise 10001, "RPackage.AddDependency", "Packages cannot be their own dependencies!"

Dim i As Integer
For i = 1 To Dependencies.Count
    If LCase(Dependencies(i).ShortName) = LCase(deppath) Then Err.Raise 10001, "RPackage.AddDependency", "File is already a dependency of this Package!"
Next i


Dim fd As Integer
Dim newPak As cGAMPackage
    fd = FindLDependency(LCase(deppath))
    If fd = 0 Then
        Set newPak = New cGAMPackage
        If newPak.FileOpen(Left(RPAK.FileName, InStrRev(RPAK.FileName, "\")) & deppath, "", OverridePassword, OverridePassword) Then
            Dependencies.Add newPak
            LoadedDependencies.Add newPak
        Else
            If newPak.ErrDesc = "Could not Load RPak file: Invalid password." Then
            
                If newPak.FileOpen(Left(RPAK.FileName, InStrRev(RPAK.FileName, "\")) & deppath, PasswordBox("Please enter password for '" & deppath & "':"), OverridePassword) Then
                    Dependencies.Add newPak
                    LoadedDependencies.Add newPak
                Else
                    Err.Raise 10001, newPak.ErrSource, newPak.ErrDesc
                End If
                
            Else
                Err.Raise 10001, newPak.ErrSource, newPak.ErrDesc
            End If
            
        End If
    Else
        Dependencies.Add LoadedDependencies(fd)
    End If
    
    AddDependency = True
  Exit Function
fehler:
  AddDependency = False
  ErrDesc = Err.Description
  ErrSource = Err.source
End Function

Public Function RemoveDependency(FName As String) As Boolean
  On Error GoTo fehler
  
  Dim i As Long
  i = FindDependency(FName)
  If i > 0 Then
    Dependencies.Remove i
  End If
  
  RemoveDependency = True
  Exit Function
fehler:
  RemoveDependency = False
  ErrDesc = Err.Description
  ErrSource = Err.source
End Function

Public Function RemoveDependencyByID(Index As Long) As Boolean
  On Error GoTo fehler
  
  Dependencies.Remove i
  RemoveDependencyByID = True
  Exit Function
fehler:
  RemoveDependencyByID = False
  ErrDesc = Err.Description
  ErrSource = Err.source
End Function

Public Function FindDependency(FName As String) As Long
  Dim i As Integer

  For i = 1 To Dependencies.Count
    If LCase(Dependencies(i).ShortName) = LCase(FName) Then FindDependency = i: Exit Function
  Next
End Function
