# ACTIVESTATE TEAPOT-PKG BEGIN TM -*- tcl -*- # -- Tcl Module # @@ Meta Begin # Package tdomhtml 0.1.0 # Meta as::author {Zoran Vasiljevic} # Meta as::build::date 2015-07-08 # Meta as::origin http://www.tdom.org/ # Meta category tdom # Meta description Tdom add-on # Meta license MPL (Mozilla Public License) # Meta platform tcl # Meta require {Tcl 8.4} # Meta subject tdom # Meta summary Tdom add-on # @@ Meta End # ACTIVESTATE TEAPOT-PKG BEGIN REQUIREMENTS package require Tcl 8.4 # ACTIVESTATE TEAPOT-PKG END REQUIREMENTS # ACTIVESTATE TEAPOT-PKG BEGIN DECLARE package provide tdomhtml 0.1.0 # ACTIVESTATE TEAPOT-PKG END DECLARE # ACTIVESTATE TEAPOT-PKG END TM #---------------------------------------------------------------------------- # Copyright (c) 1999,2000 Jochen Loewer (loewerj@hotmail.com) et al. #---------------------------------------------------------------------------- # # Rcsid: @(#)$Id$ # # Implements simple HTML layer on top of core DOM Level-1 specification, # as implemented in tDOM package. # # The contents of this file are subject to the Mozilla Public License # Version 1.1 (the "License"); you may not use this file except in # compliance with the License. You may obtain a copy of the License at # http://www.mozilla.org/MPL/ # # Software distributed under the License is distributed on an "AS IS" # basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the # License for the specific language governing rights and limitations # under the License. # # The Original Code is tDOM. # The Initial Developer of the Original Code is Jochen Loewer. # # Portions created by Jochen Loewer are Copyright (C) 1998, 1999 # Jochen Loewer. All Rights Reserved. # # Portions created by Zoran Vasiljevic are Copyright (C) 2000-2002 # Zoran Vasiljevic. All Rights Reserved. # # Portions created by Rolf Ade are Copyright (C) 1999-2002 # Rolf Ade. All Rights Reserved. # Contributor(s): # # 3 Apr 2000 Zoran Vasiljevic (zoran@v-connect.com) # Initial idea # # 20 Oct 2002 Rolf Ade (rolf@pointsman.de) # Suggestion to rewrite with new tdom :) # # 23 Oct 2002 Zoran Vasiljevic (zoran@archiware.com) # Rewritten from scratch using new tdom. # # Written by Zoran Vasiljevic # April, 2000 # #---------------------------------------------------------------------------- # # This package requires the loaded tdom # so bark early if we can't find it. # package require tdom # # Caller (usually our pkgIndex.tcl loader) will supply the package # version by defining the _V_ variable before sourcing this file. # For all other cases, we just provide the no-version package. # if {[info exists _V_] == 0} { package provide tdomhtml } else { package provide tdomhtml $_V_ } # # Declare HTML generating commands # namespace eval ::dom::domHTML { # # Create commands for generating HTML tags. This is a complete # set taken from http://www.w3.org/TR/html4/index/elements.html # variable elementNodeCmd { a abbr acronym address applet area b base basefont bdo big blockquote body br button caption center cite code col colgroup dd del dfn dir div dl dt em fieldset font form frame frameset h1 h2 h3 h4 h5 h6 head hr html i iframe img input ins isindex kbd label legend li link map menu meta noframes noscript object ol optgroup option p param pre q s samp script select small span strike strong style sub sup table tbody td textarea tfoot th thead title tr tt u ul var } foreach nodecmd $elementNodeCmd { dom createNodeCmd elementNode $nodecmd } # # Miscelaneous commands. Not part of HTML specs but needed # for generation of special DOM nodes. # variable textNodeCmd t dom createNodeCmd textNode $textNodeCmd variable commentNodeCmd c dom createNodeCmd commentNode $commentNodeCmd } #----------------------------------------------------------------------------- # ::dom::domHTML::newdoc -- # # Creates the HTML document and fils it with content. # Note: script is evaluated in the context of ::dom::domHTML namespace. #----------------------------------------------------------------------------- proc ::dom::domHTML::newdoc {script {upvars {}}} { foreach name $upvars { upvar $name $name } set doc [dom createDocument html] [$doc documentElement] appendFromScript $script return $doc } #----------------------------------------------------------------------------- # ::dom::domHTML::putdoc -- # # Convenience wrapper to serialize the document to the output channel #----------------------------------------------------------------------------- proc ::dom::domHTML::putdoc {doc chan} { [$doc documentElement] asHTML -channel $chan } #----------------------------------------------------------------------------- # ::dom::domHTML::deldoc -- # # Convenience wrapper to dispose the html document #----------------------------------------------------------------------------- proc ::dom::domHTML::deldoc {doc} { $doc delete } #----------------------------------------------------------------------------- # ::dom::domHTML::html2tcl -- # # Parses the html file and creates a Tcl script usable for passing # to the ::dom::domHTML::newdoc command. #----------------------------------------------------------------------------- proc ::dom::domHTML::html2tcl {htmlfile {outfile ""}} { # # Slurp-in the entire html file # set ichan [open $htmlfile] set html [read $ichan] close $ichan # # Create in-memory DOM tree by parsing # the html content with the built-in # tdom html parser. # dom parse -html $html doc # # Open output file and recursively # format all elements found there. # if {$outfile == ""} { set outfile [file root $htmlfile].tcl } set ochan [open $outfile w] _2tcl [$doc documentElement] $ochan close $ochan } #----------------------------------------------------------------------------- # ::dom::domHTML::_2tcl -- # # Helper procedure for recursively parsing the html tag #----------------------------------------------------------------------------- proc ::dom::domHTML::_2tcl {top ochan {indent 2} {offset 0}} { variable commentNodeCmd variable textNodeCmd variable elementNodeCmd set space [string repeat " " $offset] foreach child [$top childNodes] { switch -- [$child nodeType] { ELEMENT_NODE { # Emit the nodename as html command # and create node command if missing set nodecmd [string tolower [$child nodeName]] if {[lsearch $elementNodeCmd $name] == -1} { dom createNodeCmd elementNode $nodecmd } puts -nonewline $ochan $space puts -nonewline $ochan $nodecmd # Emit node attributes as key/value pairs foreach att [$child attributes] { puts -nonewline $ochan " " puts -nonewline $ochan [string tolower $att] puts -nonewline $ochan " " set val [_entityesc [$child getAttribute $att]] if {[regexp { } $val]} { puts -nonewline $ochan \"$val\" } else { puts -nonewline $ochan $val } } # Recurse to child nodes if {[llength [$child childNodes]]} { puts $ochan " {" _2tcl $child $ochan $indent [expr {$offset+$indent}] puts -nonewline $ochan $space puts $ochan "}" } else { puts $ochan "" } } TEXT_NODE - CDATA_SECTION_NODE { # Escape contents of text nodes puts -nonewline $ochan $space puts -nonewline $ochan "$textNodeCmd {" puts -nonewline $ochan [_entityesc [$child nodeValue]] puts $ochan "}" } COMMENT_NODE { # Pass contents of comment nodes as-is puts -nonewline $ochan $space puts -nonewline $ochan "$commentNodeCmd {" puts -nonewline $ochan [$child nodeValue] puts $ochan "}" } } } } #----------------------------------------------------------------------------- # ::dom::domHTML::_entityesc -- # # Helper procedure for entity escaping #----------------------------------------------------------------------------- proc ::dom::domHTML::_entityesc {string} { regsub -all {(&[^;]+;)} $string {\\\1} string regsub -all {([\#\[\]])} $string {\\\1} string return $string } #----------------------------------------------------------------------------- # Short usage example. # #----------------------------------------------------------------------------- if {0} { set doc [dom::domHTML::newdoc { title {t "Test document generated with tDOM"} body { table border 1 width 100 { for {set i 0} {$i < 5} {incr i} { tr { td { i { t "italic $i and " b {t "italic-bold $i"} } } } } } } }] dom::domHTML::putdoc $doc stdout dom::domHTML::deldoc $doc } # - EOF -