libs/xml/writer.factor

   1 ! Copyright (C) 2005, 2006 Daniel Ehrenberg\r
   2 ! See http://factorcode.org/license.txt for BSD license.\r
   3 IN: xml\r
   4 USING: hashtables kernel math namespaces sequences strings\r
   5     io generic ;\r
   6 \r
   7 GENERIC: write-str-elem ( elem -- )\r
   8 \r
   9 : chars>entities ( str -- str )\r
  10     #! Convert <, >, &, ' and " to HTML entities.\r
  11     [ [ dup entities hash [ % ] [ , ] ?if ] each ] "" make ;\r
  12 \r
  13 M: string write-str-elem\r
  14     chars>entities write ;\r
  15 \r
  16 M: entity write-str-elem\r
  17     CHAR: & write1 entity-name write CHAR: ; write1 ;\r
  18 \r
  19 M: reference write-str-elem\r
  20     CHAR: % write1 reference-name write CHAR: ; write1 ;\r
  21 \r
  22 UNION: str-elem string entity reference ;\r
  23 \r
  24 : print-name ( name -- )\r
  25     dup name-space dup "" = [ drop ]\r
  26     [ write CHAR: : write1 ] if\r
  27     name-tag write ;\r
  28 \r
  29 : print-props ( hash -- )\r
  30     [\r
  31         " " write swap print-name "=\"" write\r
  32         [ write-str-elem ] each "\"" write\r
  33     ] hash-each ;\r
  34 \r
  35 GENERIC: write-item ( object -- )\r
  36 \r
  37 M: str-elem write-item ! string element\r
  38     write-str-elem ;\r
  39 \r
  40 M: contained-tag write-item\r
  41     CHAR: < write1\r
  42     dup print-name\r
  43     tag-props print-props\r
  44     "/>" write ;\r
  45 \r
  46 M: open-tag write-item\r
  47     CHAR: < write1\r
  48     dup print-name\r
  49     dup tag-props print-props\r
  50     CHAR: > write1\r
  51     dup tag-children [ write-item ] each\r
  52     "</" write print-name CHAR: > write1 ;\r
  53 \r
  54 M: comment write-item\r
  55     "<!--" write comment-text write "-->" write ;\r
  56 \r
  57 M: directive write-item\r
  58     "<!" write directive-text write CHAR: > write1 ;\r
  59 \r
  60 M: instruction write-item\r
  61     "<?" write instruction-text write "?>" write ;\r
  62 \r
  63 : xml-preamble ( xml -- )\r
  64     "<?xml version=\"" write dup prolog-version write\r
  65     "\" encoding=\"" write dup prolog-encoding write\r
  66     "\" standalone=\"" write\r
  67     prolog-standalone "yes" "no" ? write\r
  68     "\"?>" write ;\r
  69 \r
  70 : write-chunk ( seq -- )\r
  71     [ write-item ] each ;\r
  72 \r
  73 : write-xml ( xml-doc -- )\r
  74     dup xml-doc-prolog xml-preamble\r
  75     dup xml-doc-before write-chunk\r
  76     dup delegate write-item\r
  77     xml-doc-after write-chunk ;\r
  78 \r
  79 : print-xml ( xml-doc -- )\r
  80     write-xml terpri ;\r
  81 \r
  82 : xml>string ( xml-doc -- string )\r
  83     [ write-xml ] string-out ;\r
  84 \r
  85 : xml-reprint ( string -- )\r
  86     string>xml print-xml ;\r
  87 \r