Создание файлов формата MS Excel 2003 в Tcl

В основу положена реализация, приведенная в вики wiki.tcl.tk Во-первых, выполнена "доработка напильником", во-вторых, реализован интерфейс в лисп-стиле.

#    Copyright 2009, Mobile Business Group
#    This program 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 3 of the License, or
#    (at your option) any later version.
#
#    This program 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, see http://www.gnu.org/licenses/.

#package provide excel 1.0

namespace eval ::excel:: {
    variable styles
    variable columnDefault
    variable rowCounter
    variable workbooks 0
    variable workSheets
    variable workbooksArray
    variable workSheetsArray
    variable data
    variable data_str
    variable style_str

    namespace export book sheet row style columntype
}

proc ::excel::createWorkbook {} {
#
# @comment  create a workbook pointer
# @result    pointer to created workbook
#
    incr ::excel::workbooks
    set workbookName workbook$::excel::workbooks
    set ::excel::workbooksArray($workbookName) 1
    return $workbookName
}

proc ::excel::createWorkSheet {workbook name} {
#
# @comment  create a worksheet pointer
# @argument workbook pointer to a workbook
# @argument name name of the worksheet
# @result    pointer to a worksheet
#
    variable data

    if {[info exists ::excel::workbooksArray($workbook)]} {
        if {![info exists ::excel::workSheets($workbook)]} {
            set ::excel::workSheets($workbook) 1
        } else {
            incr ::excel::workSheets($workbook)
        }
        set workSheetName workSheet[string range ${workbook} 8 end].$::excel::workSheets($workbook)
        set map_list [list \] {} \[ {} \\ {} \/ {} {*} {} {?} {} {<} {} {>} {} \{ {} \} {} {&} {} {'} {}]
        set data(workSheet,$::excel::workSheets($workbook),name) [string range [string map $map_list $name] 0 29]
        set data(workSheet,$::excel::workSheets($workbook)) $workSheetName
        set data(workSheet,$workSheetName) 1
        set ::excel::rowCounter($workSheetName) 0
        return $workSheetName
    } else {
        error "$workbook is not a valid workbook"
    }
}

proc ::excel::setColumnType {workSheet columnIndex type} {
#
# @comment define a column type
# @argument workSheet pointer to a workSheet
# @argument columnIndex index of column
# @argument type of column
# @result  column type is changed
#
#   variable data
#   _checkSpreadSheet $workSheet
#   set data($workSheet,row,$columnIndex,type) [string totitle $type]
}

proc ::excel::_checkSpreadSheet {workSheet} {
    variable data
    if {![info exists data(workSheet,$workSheet)]} {
        error "$workSheet is not a valid workSheet"
    }
}

proc ::excel::deleteWorkbook {workbook} {
#
# @comment  delete a workbook pointer
# @argument workbook pointer to a workbook
# @result undecoded string
#
#   variable data

    unset       ::excel::style_str
    array unset ::excel::data_str

    for {set d 1} {$d<=$::excel::workSheets($workbook)} {incr d} {
        array unset ::excel::data $d
        set workSheet $::excel::data(workSheet,$d)
        for {set i 1} {$i<=$::excel::rowCounter($workSheet)} {incr i} {
            array unset ::excel::data $workSheet*
        }
        unset ::excel::rowCounter($workSheet)
    }

    array unset ::excel::workSheetsArray
    array unset ::excel::workbooksArray
    array unset ::excel::rowCounter
}

proc ::excel::asXml {workbook} {
#
# @comment returns excel workbook as xml
# @argument workbook pointer to a workbook
# @result workbook xml representation
#

    variable data
    variable rowCounter

        set xml "<?xml version='1.0' encoding='UTF-8'?>\
   <?mso-application progid='Excel.Sheet'?>\
   <Workbook xmlns='urn:schemas-microsoft-com:office:spreadsheet'\
   xmlns:o='urn:schemas-microsoft-com:office:office'\
   xmlns:x='urn:schemas-microsoft-com:office:excel'\
   xmlns:ss='urn:schemas-microsoft-com:office:spreadsheet'\
   xmlns:html='http://www.w3.org/TR/REC-html40'>\
   <DocumentProperties xmlns='urn:schemas-microsoft-com:office:office'>\
   <Author>Mobile Business Group</Author>\
   <Created>[clock format [clock seconds] -format {%Y-%m-%dT%H:%M:%SZ}]</Created>\
   <Company>Mobile Business Group</Company>\
   </DocumentProperties>\n\
   <Styles>\n\
   <Style ss:ID='s1'>\n\
   <Alignment ss:Vertical='Bottom'/>\n\
   <Font x:CharSet='177'/>\n\
   </Style>\n"

    append xml $::excel::style_str
    append xml "</Styles>\n"

    for {set d 1} {$d<=$::excel::workSheets($workbook)} {incr d} {
        set workSheet $::excel::data(workSheet,$d)
        append xml "<Worksheet ss:Name='$::excel::data(workSheet,$d,name)'>\n\
   <Table x:FullColumns='1' x:FullRows='1'>\n"
        append xml $::excel::data_str($workSheet)
        append xml "</Table>\n</Worksheet>\n"
    }
    append xml "</Workbook>"

    return $xml
}

proc ::excel::addRow {workSheet args} {
#
# @comment add row to excel worksheet
# @argument workSheet pointer to a workSheet
# @argument args list of variables
# @result row id
#
#   variable data
#   variable data_str

    set xml {}
    append xml "<Row>\n"
    foreach arg $args {
        set dataValue   [string map [list & {&} < {<} > {>}] [lindex $arg 0]]
        set dataType    [string totitle [lindex $arg 1]]
        set dataStyle   [lindex $arg 2]
        set dataColspan {}
        if {[lindex $arg 3] ne {}} {
            set dataColspan [expr {[lindex $arg 3] - 1}]
        }
        set dataRowspan {}
        if {[lindex $arg 4] ne {}} {
            set dataRowspan [expr {[lindex $arg 4] - 1}]
        }
        if {$dataType eq {}} {
            set dataType {String}
        }
        if {[string index $dataValue 0] == "="} {
            append xml "<Cell ss:Formula='$dataValue'"
            set dataValue ""
        } else {
            append xml "<Cell"
        }
        if {$dataColspan ne {} && $dataColspan ne {-1}} {
            append xml " ss:MergeAcross='$dataColspan'"
        }
        if {$dataRowspan ne {} && $dataRowspan ne {-1}} {
            append xml " ss:MergeDown='$dataRowspan'"
        }
        if {$dataStyle ne {}} {
            append xml " ss:StyleID='$dataStyle'>\n"
        } else {
            append xml ">\n"
        }
        append xml "<Data ss:Type='$dataType'>$dataValue</Data></Cell>\n"
    }
    append xml "</Row>\n"
    append ::excel::data_str($workSheet) $xml

    return
}


proc ::excel::createStyle {workbook args} {
#
# @comment  create an excel style
# @argument workbook pointer to a workbook
# @argument args argument list
# @result style pointer
#
#   variable data

    set xml {}

    if {[info exists ::excel::styles($workbook)]} {
        incr ::excel::styles($workbook)
    } else {
        set ::excel::styles($workbook) 2
    }
    set styleName s$::excel::styles($workbook)

    array set tmp $args
    foreach z [array names tmp] {
        if {[lsearch "-font -fontcolor -background -bold" $z]==-1} {
            error "style option $z option is not supported"
        }
    }
    foreach z [list -font -fontcolor -background -bold] {
        if {[info exists tmp($z)]} {
            set style$z $tmp($z)
        } else {
            set style$z {}
        }
    }

    append xml "<Style ss:ID='$styleName'><Alignment ss:Vertical='Bottom'/>\n"
    if {${style-font} ne {} || ${style-fontcolor} ne {}} {
        append xml "<Font x:CharSet='177'"

        if {${style-font} ne {}} {
            append xml " ss:FontName='${style-font}'"
        }

        if {${style-fontcolor} ne {}} {
            append xml " ss:Color='${style-fontcolor}'"
        }

        if {${style-bold} ne {}} {
            append xml " ss:Bold='1'"
        }

        append xml "/>\n"
    }

    if {${style-background} ne {}} {
        append xml "<Interior ss:Color='${style-background}' ss:Pattern='Solid'/>\n"
    }

    append xml "</Style>\n"

    append ::excel::style_str $xml

    return $styleName
}

##########################################################################
########## Функции высокого уровня, которые используются в коде ##########
proc ::excel::book { code_block } {
    upvar 1 xmlbook xmlbook
    uplevel 1 set xmlbook [::excel::createWorkbook]

    set ::excel::style_str {}
    array set ::excel::data_str {}

    uplevel 1 $code_block
    uplevel 1 ns_adp_mimetype "application/vnd.ms-excel"
    uplevel 1 {ns_adp_puts [::excel::asXml $xmlbook]}
    uplevel 1 ::excel::deleteWorkbook $xmlbook
}

proc ::excel::sheet { name code_block } {
    upvar 1 xmlbook xmlbook
    uplevel 1 set xmlsheet [::excel::createWorkSheet $xmlbook $name]
    uplevel 1 {set ::excel::data_str($xmlsheet) {}}
    uplevel 1 $code_block
}

proc ::excel::row { args } {
    upvar 1 xmlsheet xmlsheet
    lappend cmd ::excel::addRow $xmlsheet
    append cmd " "
    append cmd $args
    uplevel 1 eval $cmd
}

proc ::excel::style { stylename args } {
    upvar 1 xmlbook xmlbook
    upvar 1 $stylename $stylename
    lappend cmd ::excel::createStyle $xmlbook
    append cmd " "
    append cmd $args
    set $stylename [eval $cmd]
}

proc ::excel::columntype { columnIndex type } {
}