HOL-OCL
/
su4sml
1
0
Fork 0
Code Issues Pull Requests Releases Activity

restructuring. should give better error messages now 

git-svn-id: https://projects.brucker.ch/su4sml/svn/infsec-import/trunk/src/su4sml@5446 3260e6d1-4efc-4170-b0a7-36055960796d
This commit is contained in:
Jürgen Doser 2006-10-18 17:38:47 +00:00
parent badb3a7342
commit 8351ae7cfe
13 changed files with 1442 additions and 1469 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
src/ROOT.ML
View File

@ -82,12 +82,16 @@ use "ocl2string.sml";
(* ****************************************************** *)
(* Main Conversion Processes *)
use "xmltree.sml";
use "xmltree_helper.sml";
use "xmltree_hooks.sml";
use "xmltree_writer.sml";
use "xmltree_parser.sml"; (* provides explicit xml-tree data structure,
abstracts away fxp package. *)
use "xml2xmi.sml"; (* conversion XML to XMI *);
use "xmi_parser.sml"; (* conversion XML to XMI *);
use "xmi_idtable.sml"; (* auxiliary table to store and dereference xmi.id's *)
use "xmi2rep.sml"; (* conversion XMI to Rep *)
use "rep_parser.sml"; (* conversion XMI to Rep *)
use "listeq.sml";

14
src/codegen/codegen.sml
View File

@ -51,23 +51,23 @@ structure JavaSecure_Gcg = GCG_Core (Java_Cartridge(SecureUML_Cartridge(Base_Car
*)
fun generate xmi_file "base" =
Base_Gcg.generate ( Xmi2Rep.readXMI xmi_file) "templates/base.tpl"
Base_Gcg.generate ( RepParser.readFile xmi_file) "templates/base.tpl"
| generate xmi_file "c#" =
CSharp_Gcg.generate ( Xmi2Rep.readXMI xmi_file) "templates/C#.tpl"
CSharp_Gcg.generate ( RepParser.readFile xmi_file) "templates/C#.tpl"
| generate xmi_file "c#_secure" =
CSharpSecure_Gcg.generate ( Xmi2Rep.readXMI xmi_file) "templates/C#_SecureUML.tpl"
CSharpSecure_Gcg.generate ( RepParser.readFile xmi_file) "templates/C#_SecureUML.tpl"
| generate xmi_file "c#_net1" =
CSharp_NET1_Gcg.generate ( Xmi2Rep.readXMI xmi_file) "templates/C#.tpl"
CSharp_NET1_Gcg.generate ( RepParser.readFile xmi_file) "templates/C#.tpl"
| generate xmi_file "c#_secure_net1" =
CSharpSecure_NET1_Gcg.generate ( Xmi2Rep.readXMI xmi_file) "templates/C#_SecureUML.tpl"
CSharpSecure_NET1_Gcg.generate ( RepParser.readFile xmi_file) "templates/C#_SecureUML.tpl"
| generate xmi_file "c#sm" =
CSharpSM_Gcg.generate (Xmi2Rep.readXMI xmi_file) "templates/C#_SM.tpl"
CSharpSM_Gcg.generate (RepParser.readFile xmi_file) "templates/C#_SM.tpl"
(*
| generate "java" = Java_Gcg.generate model "templates/java.tpl"
| generate "java_secure" = JavaSecure_Gcg.generate model "templates/java_SecureUML.tpl"
*)
(* | generate xmi_file "maude" =
Base_Gcg.generate ( Xmi2Rep.readXMI xmi_file) "templates/maude.tpl"
Base_Gcg.generate ( RepParser.readFile xmi_file) "templates/maude.tpl"
| generate xmi_file "maude_secure" =
SecureUML_Base_Gcg.generate ( Rep_SecureUML_ComponentUML.readXMI xmi_file) "templates/maude.tpl" *)
| generate _ s = print ("target language unknown : "^s^"\n"^

2
src/library.sml
View File

@ -25,7 +25,7 @@
structure library =
struct
infix |>
(* fun (x |> f) = f x;*)
fun (x |> f) = f x;
fun filter (pred: 'a->bool) : 'a list -> 'a list =

14
src/xmi2rep.sml → src/rep_parser.sml
View File

@ -1,7 +1,7 @@
(*****************************************************************************
* su4sml - a SecureUML repository for SML
*
* xmi_parser.sml - an xmi-parser for the import interface for su4sml
* rep_parser.sml - an xmi-parser for the import interface for su4sml
* Copyright (C) 2005 Achim D. Brucker <brucker@inf.ethz.ch>
* Jürgen Doser <doserj@inf.ethz.ch>
*
@ -23,10 +23,10 @@
******************************************************************************)
structure Xmi2Rep :
structure RepParser :
sig
val transformXMI : XMI.XmiContent -> Rep.Classifier list
val readXMI : string -> Rep.Classifier list
val readFile : string -> Rep.Classifier list
(* generic exception if something is wrong *)
exception IllFormed of string
end =
@ -168,7 +168,7 @@ fun transform_constraint t ({xmiid,name,body,...}:XMI.Constraint) =
(n_name,transform_expression t body)
handle NotYetImplemented => (print "Warning: in Xmi2Mdr.transform_constraint: Something is not yet implemented.\n";(NONE, triv_expr))
| IllFormed msg => (print ("Warning: in Xmi2Mdr.transform_constraint: Could not parse Constraint: "^msg^"\n");(NONE, triv_expr))
| ParseXMI.IllFormed msg => (print ("Warning: in Xmi2Mdr.transform_constraint: Could not parse Constraint: "^msg^"\n");(NONE, triv_expr))
| XmiParser.IllFormed msg => (print ("Warning: in Xmi2Mdr.transform_constraint: Could not parse Constraint: "^msg^"\n");(NONE, triv_expr))
end
fun transform_bodyconstraint result_type t ({xmiid,name,body,...}:XMI.Constraint) =
@ -183,7 +183,7 @@ fun transform_bodyconstraint result_type t ({xmiid,name,body,...}:XMI.Constraint
end
handle NotYetImplemented => (print "Warning: in Xmi2Mdr.transform_constraint: Something is not yet implemented.\n";(NONE, triv_expr))
| IllFormed msg => (print ("Warning: in Xmi2Mdr.transform_constraint: Could not parse Constraint: "^msg^"\n");(NONE, triv_expr))
| ParseXMI.IllFormed msg => (print ("Warning: in Xmi2Mdr.transform_constraint: Could not parse Constraint: "^msg^"\n");(NONE, triv_expr))
| XmiParser.IllFormed msg => (print ("Warning: in Xmi2Mdr.transform_constraint: Could not parse Constraint: "^msg^"\n");(NONE, triv_expr))
fun transform_parameter t {xmiid,name,kind,type_id} =
(name, find_classifier_type t type_id)
@ -460,8 +460,8 @@ fun transformXMI ({classifiers,constraints,packages,
* read and transform a .xmi file.
* @return a list of rep classifiers, or nil in case of problems
*)
fun readXMI f = map Rep.normalize ((transformXMI o ParseXMI.readFile) f)
handle ParseXMI.IllFormed msg =>
fun readFile f = map Rep.normalize ((transformXMI o XmiParser.readFile) f)
handle XmiParser.IllFormed msg =>
(print ("Warning: in Xmi2Mdr.readXMI: could not parse file "^
f^":\n"^msg^"\n"); nil)
| Option =>

2
src/rep_secure.sml
View File

@ -51,7 +51,7 @@ structure Security = Security
type Model = Rep_Core.Classifier list * Security.Configuration
val readXMI = Security.parse o Xmi2Rep.readXMI
val readXMI = Security.parse o RepParser.readFile
end

10
src/su4sml.cm
View File

@ -18,18 +18,22 @@ Group is
rep_secure.sml
ocl_library.sml
rep.sml
rep_parser.sml
xmi_ocl.sml
xmi_core.sml
xmi_datatypes.sml
xmi_extension_mechanisms.sml
xmi_state_machines.sml
xmi_activity_graphs.sml
xmi.sml
xmi.sml
xmi_parser.sml
xmltree.sml
xmltree_hooks.sml
xmltree_helper.sml
xmltree_parser.sml
xmltree_writer.sml
xmi_idtable.sml
ocl2string.sml
xml2xmi.sml
xmi2rep.sml
codegen/compiler/compiler_ext.sig
codegen/compiler/smlnj.sml
codegen/gcg_library.sml

1036
src/xmi_parser.sml Normal file
View File

File diff suppressed because it is too large Load Diff

1169
src/xml2xmi.sml
View File

File diff suppressed because it is too large Load Diff

84
src/xmltree.sml Normal file
View File

@ -0,0 +1,84 @@
(*****************************************************************************
* su4sml - a SecureUML repository for SML
*
* xmltree.sml - datastructure for xml files
* Copyright (C) 2005 Achim D. Brucker <brucker@inf.ethz.ch>
* Jürgen Doser <doserj@inf.ethz.ch>
*
* This file is part of su4sml.
*
* su4sml is free software; you can redistribute it and/or modify it under
* the terms of the GNU General Public License as published by the Free
* Software Foundation; either version 2 of the License, or (at your option)
* any later version.
*
* su4sml is distributed in the hope that it will be useful, but WITHOUT ANY
* WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
* FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
* details.
*
* You should have received a copy of the GNU General Public License along
* with this program; if not, write to the Free Software Foundation, Inc.,
* 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
******************************************************************************)
structure XmlTree : sig
type Attribute
type Tag = string * Attribute list
datatype Tree = Node of Tag * Tree list
| Text of string
val text : Tree -> string
val attributes : Tree -> Attribute list
val tagname : Tree -> string
val children : Tree -> Tree list
val node_children : Tree -> Tree list
val text_children : Tree -> Tree list
val optional_value_of : string -> Attribute list -> string option
val value_of : string -> Attribute list -> string
exception IllFormed of string
end = struct
open library
infix 1 |>
exception IllFormed of string
(** A name-value pair. *)
type Attribute = (string * string)
(** Tags consist of element names, and a list of attribute name-value pairs. *)
type Tag = string * Attribute list
datatype Tree = Node of Tag * Tree list
| Text of string
val filter_nodes = List.filter (fn Node x => true
| _ => false)
val filter_text = List.filter (fn Text x => true
| _ => false)
fun text (Text s) = s
| text _ = raise IllFormed "text called on Node element"
fun attributes (Node ((elem,atts),trees)) = atts
| attributes _ = raise IllFormed "attributes_of called on a Text-Node"
fun children (Node ((elem,atts),trees)) = trees
| children _ = raise IllFormed "children called on a Text-Node"
fun node_children (Node ((elem,atts),trees)) = filter_nodes trees
| node_children _ = raise IllFormed "node_children called on a Text-Node"
fun text_children (Node ((elem,atts),trees)) = filter_text trees
| text_children _ = raise IllFormed "node_children called on a Text-Node"
fun tagname (Node ((elem,atts),trees)) = elem
| tagname (Text _) = ""
fun optional_value_of string atts = Option.map #2 (List.find (fn (x,_) => x = string) atts)
fun value_of string atts = valOf (optional_value_of string atts)
handle Option => raise IllFormed ("in value_of: did not find attribute "^string)
end

97
src/xmltree_helper.sml Normal file
View File

@ -0,0 +1,97 @@
(*****************************************************************************
* su4sml - a SecureUML repository for SML
*
* xmltree_helper.sml - helper functions for xml trees
* Copyright (C) 2005 Achim D. Brucker <brucker@inf.ethz.ch>
* Jürgen Doser <doserj@inf.ethz.ch>
*
* This file is part of su4sml.
*
* su4sml is free software; you can redistribute it and/or modify it under
* the terms of the GNU General Public License as published by the Free
* Software Foundation; either version 2 of the License, or (at your option)
* any later version.
*
* su4sml is distributed in the hope that it will be useful, but WITHOUT ANY
* WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
* FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
* details.
*
* You should have received a copy of the GNU General Public License along
* with this program; if not, write to the Free Software Foundation, Inc.,
* 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
******************************************************************************)
structure XmlTreeHelper : sig
(* val skip : string -> Tree -> Tree list *)
val get_many : string -> XmlTree.Tree -> XmlTree.Tree list
val get_one : string -> XmlTree.Tree -> XmlTree.Tree
val get_maybe : string -> XmlTree.Tree -> XmlTree.Tree list
val get : string -> XmlTree.Tree -> XmlTree.Tree list
val get_optional: string -> XmlTree.Tree -> XmlTree.Tree option
val filter : string -> XmlTree.Tree list -> XmlTree.Tree list
val filter_children : string -> XmlTree.Tree -> XmlTree.Tree list
val find_some : string -> XmlTree.Tree list -> XmlTree.Tree option
val find : string -> XmlTree.Tree list -> XmlTree.Tree
val find_child : string -> XmlTree.Tree -> XmlTree.Tree
val dfs : string -> XmlTree.Tree -> XmlTree.Tree option
val exists : string -> XmlTree.Tree list -> bool
val has_child : string -> XmlTree.Tree -> bool
(* val follow : string -> XmlTree.Tree list -> XmlTree.Tree list *)
(* val followM : string -> XmlTree.Tree list -> XmlTree.Tree list *)
(* val skipM : string -> XmlTree.Tree -> XmlTree.Tree list *)
val assert : string -> XmlTree.Tree -> XmlTree.Tree
val is : XmlTree.Tree * string -> bool
(* val follow_all : string -> XmlTree.Tree list -> XmlTree.Tree list list *)
(* val apply_on : string -> (Attribute list -> 'a) -> XmlTree.Tree -> 'a*)
end =
struct
open XmlTree
fun filter string trees = List.filter (fn x => string = tagname x)
trees
fun filter_children string tree = filter string (node_children tree)
fun find_some string trees = (List.find (fn x => string = tagname x) trees)
fun find string trees = valOf (List.find (fn x => string = tagname x) trees)
handle Option => raise IllFormed ("in XmlTree.find: did not find element "
^string)
fun find_child string tree = find string (node_children tree)
handle IllFormed msg => raise IllFormed (msg^" on node "^(tagname tree))
fun dfs string tree = if tagname tree = string
then SOME tree
else Option.join (List.find Option.isSome (List.map (dfs string) (node_children tree)))
fun exists string trees = List.exists (fn x => string = tagname x) trees
fun has_child string tree = exists string (node_children tree)
fun follow string trees = node_children (find string trees)
fun skip string tree = node_children (find_child string tree)
fun followM string trees = follow string trees handle IllFormed msg => nil
fun skipM string tree = skip string tree handle IllFormed msg => nil
fun is (tree,string) = string = tagname tree
infix 2 is
fun assert string tree = if tree is string then tree
else raise IllFormed ("expected "^string^" but found "^
(tagname tree)^"\n")
(* navigate to association ends with multiplicity 1..* *)
fun get_many string tree = skip string tree
(* navigate to association ends with multiplicity 1 *)
fun get_one string tree = hd (skip string tree)
(* navigate to association ends with multiplicity 0..* *)
fun get_maybe string tree = skipM string tree
val get = get_maybe
(* navigate to association ends with multiplicity 0..1 *)
fun get_optional string tree = Option.map (hd o node_children)
(find_some string (node_children tree))
(* fun follow_all string trees = map node_children (filter string trees) *)
end

92
src/xmltree_hooks.sml Normal file
View File

@ -0,0 +1,92 @@
(*****************************************************************************
* su4sml - a SecureUML repository for SML
*
* xmltree_hooks.sml - hooks for the xml-parser
* Copyright (C) 2005 Achim D. Brucker <brucker@inf.ethz.ch>
* Jürgen Doser <doserj@inf.ethz.ch>
*
* This file is part of su4sml.
*
* su4sml is free software; you can redistribute it and/or modify it under
* the terms of the GNU General Public License as published by the Free
* Software Foundation; either version 2 of the License, or (at your option)
* any later version.
*
* su4sml is distributed in the hope that it will be useful, but WITHOUT ANY
* WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
* FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
* details.
*
* You should have received a copy of the GNU General Public License along
* with this program; if not, write to the Free Software Foundation, Inc.,
* 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
******************************************************************************)
structure XmlTreeHooks : Hooks =
struct
open IgnoreHooks XmlTree UniChar HookData
type AppData = Dtd.Dtd * Tree list * (Tag * Tree list) list
type AppFinal = Tree
(* val appStart = (nil,nil) *)
fun attspec2name dtd nil = nil
| attspec2name dtd ((i,AP_PRESENT (s,v,_),_)::atts) =
let val attName = UniChar.Data2String (Dtd.Index2AttNot dtd i)
val attValue = UniChar.Vector2String v
in
(attName,attValue)::(attspec2name dtd atts)
end
| attspec2name dtd ((i,AP_DEFAULT (s,v,_),_)::atts) =
let val attName = UniChar.Data2String (Dtd.Index2AttNot dtd i)
val attValue = UniChar.Vector2String v
in
(attName,attValue)::(attspec2name dtd atts)
end
| attspec2name dtd (_::atts) = attspec2name dtd atts
fun hookStartTag ((dtd,content, stack), (_,elem,atts,_,empty)) =
let val elemName = UniChar.Data2String (Dtd.Index2Element dtd elem)
val attNames = attspec2name dtd atts in
if empty
then (dtd,Node ((elemName,attNames),nil)::content,stack)
else (dtd,nil,((elemName,attNames),content)::stack)
end
fun hookEndTag ((dtd,_,nil),_) = raise IllFormed "in hookEndTag: illformed XML"
| hookEndTag ((dtd,content,(tag,content')::stack),_) =
(dtd,Node (tag,rev content)::content',stack)
fun hookData ((dtd,content,stack),(_,vec,_)) =
(dtd,Text (UniChar.Vector2String vec)::content,stack)
fun hookCData ((dtd,content,stack),(_,vec)) =
(dtd,Text (UniChar.Vector2String vec)::content,stack)
fun hookCharRef ((dtd,content,stack),(_,c,_)) = (* FIX *)
(dtd,content,stack)
fun hookFinish (dtd,[elem],nil) = elem
| hookFinish _ = raise IllFormed "in hookFinish: illformed XML"
fun print_message (pos,msg) =
TextIO.output (TextIO.stdErr, ErrorString.Position2String pos^": "^msg)
fun hookError (x as (dtd,content,stack),(pos,ErrorData.ERR_NO_DTD)) =
(Dtd.setHasDtd dtd; x)
| hookError (x,(pos,err)) =
(print_message (pos, "Error: "^
(String.concatWith " " (Errors.errorMessage err))^
"\n");
x)
fun hookWarning (x,(pos,warn)) =
(print_message (pos, "Warning: "^
(String.concatWith " " (Errors.warningMessage warn))^
"\n");
x)
end

283
src/xmltree_parser.sml
View File

@ -23,209 +23,7 @@
******************************************************************************)
structure XmlTree :
sig
type Attribute
type Tag = string * Attribute list
datatype Tree = Node of Tag * Tree list
| Text of string
val text_of : Tree -> string
val tag_of : Tree -> Tag
val attributes_of : Tree -> Attribute list
val children_of : Tree -> Tree list
val node_children_of : Tree -> Tree list
val text_children_of : Tree -> Tree list
val tagname_of : Tree -> string
val attvalue_of : string -> Attribute list -> string option
val skip : string -> Tree -> Tree list
val get_many : string -> Tree -> Tree list
val get_one : string -> Tree -> Tree
val get_maybe : string -> Tree -> Tree list
val get : string -> Tree -> Tree list
val get_optional: string -> Tree -> Tree option
val filter : string -> Tree list -> Tree list
val filter_children : string -> Tree -> Tree list
val find_some : string -> Tree list -> Tree option
val find : string -> Tree list -> Tree
val find_child : string -> Tree -> Tree
val dfs : string -> Tree -> Tree option
val exists : string -> Tree list -> bool
val has_child : string -> Tree -> bool
val follow : string -> Tree list -> Tree list
val followM : string -> Tree list -> Tree list
val skipM : string -> Tree -> Tree list
(* val follow_all : string -> Tree list -> Tree list list *)
val apply_on : string -> (Attribute list -> Tree list -> 'a) -> Tree -> 'a
exception IllFormed of string
end =
struct
open library
exception IllFormed of string
(** A name-value pair. *)
type Attribute = (string * string)
(** Tags consist of element names, and a list of attribute name-value pairs. *)
type Tag = string * Attribute list
datatype Tree = Node of Tag * Tree list
| Text of string
val filter_nodes = List.filter (fn Node x => true
| _ => false)
val filter_text = List.filter (fn Text x => true
| _ => false)
fun text_of (Text s) = s
| text_of _ = raise IllFormed "text_of called on Node element"
fun tag_of (Node (tag,trees)) = tag
| tag_of _ = raise IllFormed "tag_of called on a Text-Node"
fun attributes_of (Node ((elem,atts),trees)) = atts
| attributes_of _ = raise IllFormed "attributes_of called on a Text-Node"
fun children_of (Node ((elem,atts),trees)) = trees
| children_of _ = raise IllFormed "children_of called on a Text-Node"
fun node_children_of (Node ((elem,atts),trees)) = filter_nodes trees
| node_children_of _ = raise IllFormed "node_children_of called on a Text-Node"
fun text_children_of (Node ((elem,atts),trees)) = filter_text trees
| text_children_of _ = raise IllFormed "node_children_of called on a Text-Node"
fun tagname_of (Node ((elem,atts),trees)) = elem
| tagname_of (Text _) = ""
fun attvalue_of string atts = Option.map #2 (List.find (fn (x,_) => x = string) atts)
fun filter string trees = List.filter (fn x => string = tagname_of x)
trees
fun filter_children string tree = filter string (node_children_of tree)
fun find_some string trees = (List.find (fn x => string = tagname_of x) trees)
fun find string trees = valOf (List.find (fn x => string = tagname_of x) trees)
handle Option => raise IllFormed ("in XmlTree.find: did not find element "
^string)
fun find_child string tree = find string (node_children_of tree)
handle IllFormed msg => raise IllFormed (msg^" on node "^(tagname_of tree))
fun dfs string tree = if tagname_of tree = string
then SOME tree
else Option.join (List.find Option.isSome (List.map (dfs string) (node_children_of tree)))
fun exists string trees = List.exists (fn x => string = tagname_of x) trees
fun has_child string tree = exists string (node_children_of tree)
fun follow string trees = node_children_of (find string trees)
fun skip string tree = node_children_of (find string (node_children_of tree))
fun followM string trees = follow string trees handle IllFormed msg => nil
fun skipM string tree = skip string tree handle IllFormed msg => nil
(* navigate to association ends with multiplicity 1..* *)
fun get_many string tree = skip string tree
(* navigate to association ends with multiplicity 1 *)
fun get_one string tree = hd (skip string tree)
(* navigate to association ends with multiplicity 0..* *)
fun get_maybe string tree = skipM string tree
val get = get_maybe
(* navigate to association ends with multiplicity 0..1 *)
fun get_optional string tree = Option.map (hd o node_children_of)
(find_some string (node_children_of tree))
(* fun follow_all string trees = map node_children_of (filter string trees) *)
fun apply_on name f tree =
let val tagname = tagname_of tree
in
if tagname = name
then f (attributes_of tree) (node_children_of tree)
else raise IllFormed ("XmlTree.apply_on "^name^" called\n")
handle IllFormed msg =>
raise IllFormed ("Error in XmlTree.apply_on "^tagname)
end
end
structure XmlTreeHooks : Hooks =
struct
open IgnoreHooks XmlTree UniChar HookData
exception IllFormed
type AppData = Dtd.Dtd * Tree list * (Tag * Tree list) list
type AppFinal = Tree
(* val appStart = (nil,nil) *)
fun attspec2name dtd nil = nil
| attspec2name dtd ((i,AP_PRESENT (s,v,_),_)::atts) =
let val attName = UniChar.Data2String (Dtd.Index2AttNot dtd i)
val attValue = UniChar.Vector2String v
in
(attName,attValue)::(attspec2name dtd atts)
end
| attspec2name dtd ((i,AP_DEFAULT (s,v,_),_)::atts) =
let val attName = UniChar.Data2String (Dtd.Index2AttNot dtd i)
val attValue = UniChar.Vector2String v
in
(attName,attValue)::(attspec2name dtd atts)
end
| attspec2name dtd (_::atts) = attspec2name dtd atts
fun hookStartTag ((dtd,content, stack), (_,elem,atts,_,empty)) =
let val elemName = UniChar.Data2String (Dtd.Index2Element dtd elem)
val attNames = attspec2name dtd atts in
if empty
then (dtd,Node ((elemName,attNames),nil)::content,stack)
else (dtd,nil,((elemName,attNames),content)::stack)
end
fun hookEndTag ((dtd,_,nil),_) = raise IllFormed
| hookEndTag ((dtd,content,(tag,content')::stack),_) =
(dtd,Node (tag,rev content)::content',stack)
fun hookData ((dtd,content,stack),(_,vec,_)) =
(dtd,Text (UniChar.Vector2String vec)::content,stack)
fun hookCData ((dtd,content,stack),(_,vec)) =
(dtd,Text (UniChar.Vector2String vec)::content,stack)
fun hookCharRef ((dtd,content,stack),(_,c,_)) = (* FIX *)
(dtd,content,stack)
fun hookFinish (dtd,[elem],nil) = elem
| hookFinish _ = raise IllFormed
fun print_message (pos,msg) =
TextIO.output (TextIO.stdErr, ErrorString.Position2String pos^": "^msg)
fun hookError (x as (dtd,content,stack),(pos,ErrorData.ERR_NO_DTD)) =
(Dtd.setHasDtd dtd; x)
| hookError (x,(pos,err)) =
(print_message (pos, "Error: "^
(String.concatWith " " (Errors.errorMessage err))^
"\n");
x)
fun hookWarning (x,(pos,warn)) =
(print_message (pos, "Warning: "^
(String.concatWith " " (Errors.warningMessage warn))^
"\n");
x)
end
structure ParseXmlTree : sig
structure XmlTreeParser : sig
val readFile : string -> XmlTree.Tree
end =
struct
@ -234,9 +32,9 @@ open library
exception FileNotFound of string
structure Parser = Parse (structure Dtd = Dtd
structure Hooks = XmlTreeHooks
structure ParserOptions = ParserOptions ()
structure Resolve = ResolveNull)
structure Hooks = XmlTreeHooks
structure ParserOptions = ParserOptions ()
structure Resolve = ResolveNull)
fun readFile filename =
let val currentDir = OS.FileSys.getDir()
@ -287,76 +85,3 @@ fun readFile filename =
end
(* supposed to print a XmlTree to a xml file. *)
(* Works in principle, but is not UTF-8 clean *)
structure WriteXmlTree: sig
val writeFile : string -> XmlTree.Tree -> unit
val writeStdOut : XmlTree.Tree -> unit
end =
struct
open XmlTree
val escape = String.translate(fn #"'" => "&apos;"
| #"<" => "&lt;"
| #">" => "&gt;"
| #"\"" => "&quot;"
| #"&" => "&amp;"
| c => str(c))
val escape2 = String.translate(fn #"<" => "&lt;"
| #">" => "&gt;"
| #"\"" => "&quot;"
| #"&" => "&amp;"
| c => str(c))
fun writeAttribute stream (name,value) =
TextIO.output (stream, " "^(escape name)^"=\""^(escape2 value)^"\"")
fun writeEndTag stream name = TextIO.output (stream,"</"^(escape name)^">\n")
fun writeStartTag stream tree =
(TextIO.output (stream,"<"^escape (tagname_of tree));
List.app (writeAttribute stream) (attributes_of tree);
TextIO.output (stream,">\n"))
fun writeStartEndTag stream tree =
(TextIO.output (stream,"<"^escape (tagname_of tree));
List.app (writeAttribute stream) (attributes_of tree);
TextIO.output (stream, " />\n"))
fun writeIndent stream 0 = ()
| writeIndent stream n = (TextIO.output (stream, " "); writeIndent stream (n-1))
fun writeXmlTree indent stream (Text s) =
(writeIndent stream indent;
TextIO.output (stream, s^"\n"))
| writeXmlTree indent stream tree =
let val elemName = escape (tagname_of tree)
in
writeIndent stream indent;
if children_of tree = nil
then writeStartEndTag stream tree
else (writeStartTag stream tree;
List.app (writeXmlTree (indent+1) stream) (children_of tree);
writeIndent stream indent;
writeEndTag stream elemName)
end
fun writeFile filename tree =
let val stream = TextIO.openOut filename
in
TextIO.output (stream,"<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n");
writeXmlTree 0 stream tree;
TextIO.closeOut stream
end
fun writeStdOut tree =
let val stream = TextIO.stdOut
in
TextIO.output (stream,"<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n");
writeXmlTree 0 stream tree;
TextIO.closeOut stream
end
end

100
src/xmltree_writer.sml Normal file
View File

@ -0,0 +1,100 @@
(*****************************************************************************
* su4sml - a SecureUML repository for SML
*
* xmltree_writer.sml - a module for writing xml trees
* Copyright (C) 2005 Achim D. Brucker <brucker@inf.ethz.ch>
* Jürgen Doser <doserj@inf.ethz.ch>
*
* This file is part of su4sml.
*
* su4sml is free software; you can redistribute it and/or modify it under
* the terms of the GNU General Public License as published by the Free
* Software Foundation; either version 2 of the License, or (at your option)
* any later version.
*
* su4sml is distributed in the hope that it will be useful, but WITHOUT ANY
* WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
* FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
* details.
*
* You should have received a copy of the GNU General Public License along
* with this program; if not, write to the Free Software Foundation, Inc.,
* 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
******************************************************************************)
(* supposed to print a XmlTree to a xml file. *)
(* Works in principle, but is not UTF-8 clean *)
structure WriteXmlTree: sig
val writeFile : string -> XmlTree.Tree -> unit
val writeStdOut : XmlTree.Tree -> unit
end =
struct
open XmlTree
val escape = String.translate(fn #"'" => "&apos;"
| #"<" => "&lt;"
| #">" => "&gt;"
| #"\"" => "&quot;"
| #"&" => "&amp;"
| c => str(c))
val escape2 = String.translate(fn #"<" => "&lt;"
| #">" => "&gt;"
| #"\"" => "&quot;"
| #"&" => "&amp;"
| c => str(c))
fun writeAttribute stream (name,value) =
TextIO.output (stream, " "^(escape name)^"=\""^(escape2 value)^"\"")
fun writeEndTag stream name = TextIO.output (stream,"</"^(escape name)^">\n")
fun writeStartTag stream tree =
(TextIO.output (stream,"<"^escape (tagname tree));
List.app (writeAttribute stream) (attributes tree);
TextIO.output (stream,">\n"))
fun writeStartEndTag stream tree =
(TextIO.output (stream,"<"^escape (tagname tree));
List.app (writeAttribute stream) (attributes tree);
TextIO.output (stream, " />\n"))
fun writeIndent stream 0 = ()
| writeIndent stream n = (TextIO.output (stream, " "); writeIndent stream (n-1))
fun writeXmlTree indent stream (Text s) =
(writeIndent stream indent;
TextIO.output (stream, s^"\n"))
| writeXmlTree indent stream tree =
let val elemName = escape (tagname tree)
in
writeIndent stream indent;
if children tree = nil
then writeStartEndTag stream tree
else (writeStartTag stream tree;
List.app (writeXmlTree (indent+1) stream) (children tree);
writeIndent stream indent;
writeEndTag stream elemName)
end
fun writeFile filename tree =
let val stream = TextIO.openOut filename
in
TextIO.output (stream,"<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n");
writeXmlTree 0 stream tree;
TextIO.closeOut stream
end
fun writeStdOut tree =
let val stream = TextIO.stdOut
in
TextIO.output (stream,"<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n");
writeXmlTree 0 stream tree;
TextIO.closeOut stream
end
end