mirror of
https://github.com/smarty-php/smarty.git
synced 2025-11-03 22:01:36 +01:00
420 lines
15 KiB
Plaintext
Executable File
420 lines
15 KiB
Plaintext
Executable File
;; $Id$
|
|
;;
|
|
;; This file is part of the Modular DocBook Stylesheet distribution.
|
|
;; See ../README or http://www.berkshire.net/~norm/dsssl/
|
|
;;
|
|
;; Table support completely reimplemented by norm 15/16 Nov 1997.
|
|
;; Adapted from print support.
|
|
;;
|
|
;; ======================================================================
|
|
;;
|
|
;; This code is intended to implement the SGML Open Exchange Table Model
|
|
;; (http://www.sgmlopen.org/sgml/docs/techpubs.htm) as far as is possible
|
|
;; in HTML. There are a few areas where this code probably fails to
|
|
;; perfectly implement the model:
|
|
;;
|
|
;; - Mixed column width units (4*+2pi) are not supported.
|
|
;; - The behavior that results from mixing relative units with
|
|
;; absolute units has not been carefully considered.
|
|
;;
|
|
;; ======================================================================
|
|
;;
|
|
;; My goal in reimplementing the table model was to provide correct
|
|
;; formatting in tables that use MOREROWS. The difficulty is that
|
|
;; correct formatting depends on calculating the column into which
|
|
;; an ENTRY will fall.
|
|
;;
|
|
;; This is a non-trivial problem because MOREROWS can hang down from
|
|
;; preceding rows and ENTRYs may specify starting columns (skipping
|
|
;; preceding ones).
|
|
;;
|
|
;; A simple, elegant recursive algorithm exists. Unfortunately it
|
|
;; requires calculating the column number of every preceding cell
|
|
;; in the entire table. Without memoization, performance is unacceptable
|
|
;; even in relatively small tables (5x5, for example).
|
|
;;
|
|
;; In order to avoid recursion, the algorithm used below is one that
|
|
;; works forward from the beginning of the table and "passes along"
|
|
;; the relevant information (column number of the preceding cell and
|
|
;; overhang from the MOREROWS in preceding rows).
|
|
;;
|
|
;; Unfortunately, this means that element construction rules
|
|
;; can't always be used to fire the appropriate rule. Instead,
|
|
;; each TGROUP has to process each THEAD/BODY/FOOT explicitly.
|
|
;; And each of those must process each ROW explicitly, then each
|
|
;; ENTRY/ENTRYTBL explicitly.
|
|
;;
|
|
;; ----------------------------------------------------------------------
|
|
;;
|
|
;; I attempted to simplify this code by relying on inheritence from
|
|
;; table-column flow objects, but that wasn't entirely successful.
|
|
;; Horizontally spanning cells didn't seem to inherit from table-column
|
|
;; flow objects that didn't specify equal spanning. There seemed to
|
|
;; be other problems as well, but they could have been caused by coding
|
|
;; errors on my part.
|
|
;;
|
|
;; Anyway, by the time I understood how I could use table-column
|
|
;; flow objects for inheritence, I'd already implemented all the
|
|
;; machinery below to "work it out by hand".
|
|
;;
|
|
;; ======================================================================
|
|
;; NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
|
|
;; ----------------------------------------------------------------------
|
|
;; A fairly large chunk of this code is in dbcommon.dsl!
|
|
;; ======================================================================
|
|
|
|
;; Default for COLSEP/ROWSEP if unspecified
|
|
(define %cals-rule-default% "0")
|
|
|
|
;; Default for VALIGN if unspecified
|
|
(define %cals-valign-default% "TOP")
|
|
|
|
;; ======================================================================
|
|
;; Convert colwidth units into table-unit measurements
|
|
|
|
(define (colwidth-length lenstr)
|
|
(if (string? lenstr)
|
|
(let ((number (length-string-number-part lenstr))
|
|
(units (length-string-unit-part lenstr)))
|
|
(if (or (string=? units "*") (string=? number ""))
|
|
;; relative units or no number, give up
|
|
0pt
|
|
(if (string=? units "")
|
|
;; no units, default to pixels
|
|
(* (string->number number) 1px)
|
|
(let* ((unum (string->number number))
|
|
(uname (case-fold-down units)))
|
|
(case uname
|
|
(("mm") (* unum 1mm))
|
|
(("cm") (* unum 1cm))
|
|
(("in") (* unum 1in))
|
|
(("pi") (* unum 1pi))
|
|
(("pt") (* unum 1pt))
|
|
(("px") (* unum 1px))
|
|
;; unrecognized units; use pixels
|
|
(else (* unum 1px)))))))
|
|
;; lenstr is not a string...probably #f
|
|
0pt))
|
|
|
|
(define (cals-relative-colwidth? colwidth)
|
|
(if (string? colwidth)
|
|
(let ((strlen (string-length colwidth)))
|
|
(if (string=? colwidth "*")
|
|
#t
|
|
(string=? (substring colwidth (- strlen 1) strlen) "*")))
|
|
#f))
|
|
|
|
(define (cals-relative-colwidth colwidth)
|
|
(let ((number (length-string-number-part colwidth))
|
|
(units (length-string-unit-part colwidth)))
|
|
(if (string=? units "*")
|
|
(if (string=? number "")
|
|
1
|
|
(string->number number))
|
|
0)))
|
|
|
|
(define (cell-relative-colwidth cell relative)
|
|
(let* ((tgroup (find-tgroup cell)))
|
|
(let loop ((colspecs (select-elements (children tgroup)
|
|
(normalize "colspec")))
|
|
(reltotal 0))
|
|
(if (node-list-empty? colspecs)
|
|
(string-append (number->string (round (* (/ relative reltotal) 100))) "%")
|
|
(loop (node-list-rest colspecs)
|
|
(+ reltotal (cals-relative-colwidth
|
|
(colspec-colwidth
|
|
(node-list-first colspecs)))))))))
|
|
|
|
(define (cell-colwidth cell colnum)
|
|
(let* ((entry (ancestor-member cell (list (normalize "entry")
|
|
(normalize "entrytbl"))))
|
|
(colspec (find-colspec-by-number colnum))
|
|
(colwidth (colspec-colwidth colspec))
|
|
(width (round (/ (colwidth-length colwidth) 1px))))
|
|
(if (node-list-empty? colspec)
|
|
""
|
|
(if (and (equal? (hspan entry) 1) colwidth)
|
|
(if (cals-relative-colwidth? colwidth)
|
|
(cell-relative-colwidth cell (cals-relative-colwidth colwidth))
|
|
(number->string width))
|
|
""))))
|
|
|
|
;; ======================================================================
|
|
|
|
(define (cell-align cell colnum)
|
|
(let* ((entry (ancestor-member cell (list (normalize "entry")
|
|
(normalize "entrytbl"))))
|
|
(tgroup (find-tgroup entry))
|
|
(spanname (attribute-string (normalize "spanname") entry))
|
|
(calsalign (if (attribute-string (normalize "align") entry)
|
|
(attribute-string (normalize "align") entry)
|
|
(if (and spanname
|
|
(spanspec-align (find-spanspec spanname)))
|
|
(spanspec-align (find-spanspec spanname))
|
|
(if (colspec-align (find-colspec-by-number colnum))
|
|
(colspec-align (find-colspec-by-number colnum))
|
|
(if (tgroup-align tgroup)
|
|
(tgroup-align tgroup)
|
|
(normalize "left")))))))
|
|
(cond
|
|
((equal? calsalign (normalize "left")) "LEFT")
|
|
((equal? calsalign (normalize "center")) "CENTER")
|
|
((equal? calsalign (normalize "right")) "RIGHT")
|
|
(else "LEFT"))))
|
|
|
|
(define (cell-valign cell colnum)
|
|
(let* ((entry (ancestor-member cell (list (normalize "entry")
|
|
(normalize "entrytbl"))))
|
|
(row (ancestor (normalize "row") entry))
|
|
(tbody (ancestor-member cell (list (normalize "tbody")
|
|
(normalize "thead") (normalize "tfoot"))))
|
|
(tgroup (find-tgroup entry))
|
|
(calsvalign (if (attribute-string (normalize "valign") entry)
|
|
(attribute-string (normalize "valign") entry)
|
|
(if (attribute-string (normalize "valign") row)
|
|
(attribute-string (normalize "valign") row)
|
|
(if (attribute-string (normalize "valign") tbody)
|
|
(attribute-string (normalize "valign") tbody)
|
|
%cals-valign-default%)))))
|
|
(cond
|
|
((equal? calsvalign (normalize "top")) "TOP")
|
|
((equal? calsvalign (normalize "middle")) "MIDDLE")
|
|
((equal? calsvalign (normalize "bottom")) "BOTTOM")
|
|
(else "MIDDLE"))))
|
|
|
|
;; ======================================================================
|
|
;; Element rules
|
|
|
|
(element tgroup
|
|
(let* ((wrapper (parent (current-node)))
|
|
(frameattr (attribute-string (normalize "frame") wrapper))
|
|
(pgwide (attribute-string (normalize "pgwide") wrapper))
|
|
(footnotes (select-elements (descendants (current-node))
|
|
(normalize "footnote")))
|
|
(border (if (equal? frameattr (normalize "none"))
|
|
'(("BORDER" "0"))
|
|
'(("BORDER" "1"))))
|
|
(width (if (equal? pgwide "1")
|
|
(list (list "WIDTH" ($table-width$)))
|
|
'()))
|
|
(head (select-elements (children (current-node)) (normalize "thead")))
|
|
(body (select-elements (children (current-node)) (normalize "tbody")))
|
|
(feet (select-elements (children (current-node)) (normalize "tfoot"))))
|
|
(make element gi: "TABLE"
|
|
attributes: (append
|
|
border
|
|
width
|
|
(if %cals-table-class%
|
|
(list (list "CLASS" %cals-table-class%))
|
|
'()))
|
|
(process-node-list head)
|
|
(process-node-list body)
|
|
(process-node-list feet)
|
|
(make-table-endnotes))))
|
|
|
|
(element entrytbl ;; sortof like a tgroup...
|
|
(let* ((wrapper (parent (parent (parent (parent (current-node))))))
|
|
;; table tgroup tbody row
|
|
(frameattr (attribute-string (normalize "frame") wrapper))
|
|
(tgrstyle (attribute-string (normalize "tgroupstyle")))
|
|
(border (if (and (or (equal? frameattr (normalize "none"))
|
|
(equal? tgrstyle (normalize "noborder")))
|
|
(not (equal? tgrstyle (normalize "border"))))
|
|
'(("BORDER" "0"))
|
|
'(("BORDER" "1"))))
|
|
(head (select-elements (children (current-node)) (normalize "thead")))
|
|
(body (select-elements (children (current-node)) (normalize "tbody"))))
|
|
(make element gi: "TABLE"
|
|
attributes: (append
|
|
border
|
|
(if %cals-table-class%
|
|
(list (list "CLASS" %cals-table-class%))
|
|
'()))
|
|
(process-node-list head)
|
|
(process-node-list body))))
|
|
|
|
(element colspec
|
|
(empty-sosofo))
|
|
|
|
(element spanspec
|
|
(empty-sosofo))
|
|
|
|
(element thead
|
|
(if %html40%
|
|
(make element gi: "THEAD"
|
|
($process-table-body$ (current-node)))
|
|
($process-table-body$ (current-node))))
|
|
|
|
(element tfoot
|
|
(if %html40%
|
|
(make element gi: "TFOOT"
|
|
($process-table-body$ (current-node)))
|
|
($process-table-body$ (current-node))))
|
|
|
|
(element tbody
|
|
(if %html40%
|
|
(make element gi: "TBODY"
|
|
($process-table-body$ (current-node)))
|
|
($process-table-body$ (current-node))))
|
|
|
|
(element row
|
|
(empty-sosofo)) ;; this should never happen, they're processed explicitly
|
|
|
|
(element entry
|
|
(empty-sosofo)) ;; this should never happen, they're processed explicitly
|
|
|
|
;; ======================================================================
|
|
;; Functions that handle processing of table bodies, rows, and cells
|
|
|
|
(define ($process-table-body$ body)
|
|
(let* ((tgroup (find-tgroup body))
|
|
(cols (string->number (attribute-string (normalize "cols")
|
|
tgroup))))
|
|
(let loop ((rows (select-elements (children body) (normalize "row")))
|
|
(overhang (constant-list 0 cols)))
|
|
(if (node-list-empty? rows)
|
|
(empty-sosofo)
|
|
(make sequence
|
|
($process-row$ (node-list-first rows) overhang)
|
|
(loop (node-list-rest rows)
|
|
(update-overhang (node-list-first rows) overhang)))))))
|
|
|
|
(define ($process-row$ row overhang)
|
|
(let* ((tgroup (find-tgroup row))
|
|
(rowcells (node-list-filter-out-pis (children row)))
|
|
(maxcol (string->number (attribute-string (normalize "cols") tgroup)))
|
|
(lastentry (node-list-last rowcells))
|
|
(table (ancestor-member tgroup (list (normalize "table")
|
|
(normalize "informaltable"))))
|
|
(rowsep (if (attribute-string (normalize "rowsep") row)
|
|
(attribute-string (normalize "rowsep") row)
|
|
(if (attribute-string (normalize "rowsep") tgroup)
|
|
(attribute-string (normalize "rowsep") tgroup)
|
|
(if (attribute-string (normalize "rowsep") table)
|
|
(attribute-string (normalize "rowsep") table)
|
|
%cals-rule-default%))))
|
|
(after-row-border (if rowsep
|
|
(> (string->number rowsep) 0)
|
|
#f)))
|
|
(make element gi: "TR"
|
|
(let loop ((cells rowcells)
|
|
(prevcell (empty-node-list)))
|
|
(if (node-list-empty? cells)
|
|
(empty-sosofo)
|
|
(make sequence
|
|
($process-cell$ (node-list-first cells)
|
|
prevcell overhang)
|
|
(loop (node-list-rest cells)
|
|
(node-list-first cells)))))
|
|
|
|
;; add any necessary empty cells to the end of the row
|
|
(let loop ((colnum (overhang-skip overhang
|
|
(+ (cell-column-number
|
|
lastentry overhang)
|
|
(hspan lastentry)))))
|
|
(if (> colnum maxcol)
|
|
(empty-sosofo)
|
|
(make sequence
|
|
(make element gi: "TD"
|
|
(make entity-ref name: "nbsp"))
|
|
(loop (overhang-skip overhang (+ colnum 1)))))))))
|
|
|
|
(define (empty-cell? entry)
|
|
;; Return #t if and only if entry is empty (or contains only PIs)
|
|
(let loop ((nl (children entry)))
|
|
(if (node-list-empty? nl)
|
|
#t
|
|
(let* ((node (node-list-first nl))
|
|
(nodeclass (node-property 'class-name node))
|
|
(nodechar (if (equal? nodeclass 'data-char)
|
|
(node-property 'char node)
|
|
#f))
|
|
(whitespace? (and (equal? nodeclass 'data-char)
|
|
(or (equal? nodechar #\space)
|
|
(equal? (data node) "	")
|
|
(equal? (data node) " ")
|
|
(equal? (data node) " ")))))
|
|
(if (not (or (equal? (node-property 'class-name node) 'pi)
|
|
whitespace?))
|
|
#f
|
|
(loop (node-list-rest nl)))))))
|
|
|
|
(define ($process-cell$ entry preventry overhang)
|
|
(let* ((colnum (cell-column-number entry overhang))
|
|
(lastcellcolumn (if (node-list-empty? preventry)
|
|
0
|
|
(- (+ (cell-column-number preventry overhang)
|
|
(hspan preventry))
|
|
1)))
|
|
(lastcolnum (if (> lastcellcolumn 0)
|
|
(overhang-skip overhang lastcellcolumn)
|
|
0))
|
|
(htmlgi (if (have-ancestor? (normalize "tbody") entry)
|
|
"TD"
|
|
"TH")))
|
|
(make sequence
|
|
(if (node-list-empty? (preced entry))
|
|
(if (attribute-string (normalize "id") (parent entry))
|
|
(make element gi: "A"
|
|
attributes: (list
|
|
(list
|
|
"NAME"
|
|
(attribute-string (normalize "id")
|
|
(parent entry))))
|
|
(empty-sosofo))
|
|
(empty-sosofo))
|
|
(empty-sosofo))
|
|
|
|
(if (attribute-string (normalize "id") entry)
|
|
(make element gi: "A"
|
|
attributes: (list
|
|
(list
|
|
"NAME"
|
|
(attribute-string (normalize "id") entry)))
|
|
(empty-sosofo))
|
|
(empty-sosofo))
|
|
|
|
;; This is a little bit complicated. We want to output empty cells
|
|
;; to skip over missing data. We start count at the column number
|
|
;; arrived at by adding 1 to the column number of the previous entry
|
|
;; and skipping over any MOREROWS overhanging entrys. Then for each
|
|
;; iteration, we add 1 and skip over any overhanging entrys.
|
|
(let loop ((count (overhang-skip overhang (+ lastcolnum 1))))
|
|
(if (>= count colnum)
|
|
(empty-sosofo)
|
|
(make sequence
|
|
(make element gi: htmlgi
|
|
(make entity-ref name: "nbsp")
|
|
;; (literal (number->string lastcellcolumn) ", ")
|
|
;; (literal (number->string lastcolnum) ", ")
|
|
;; (literal (number->string (hspan preventry)) ", ")
|
|
;; (literal (number->string colnum ", "))
|
|
;; ($debug-pr-overhang$ overhang)
|
|
)
|
|
(loop (overhang-skip overhang (+ count 1))))))
|
|
|
|
; (if (equal? (gi entry) (normalize "entrytbl"))
|
|
; (make element gi: htmlgi
|
|
; (literal "ENTRYTBL not supported."))
|
|
(make element gi: htmlgi
|
|
attributes: (append
|
|
(if (> (hspan entry) 1)
|
|
(list (list "COLSPAN" (number->string (hspan entry))))
|
|
'())
|
|
(if (> (vspan entry) 1)
|
|
(list (list "ROWSPAN" (number->string (vspan entry))))
|
|
'())
|
|
(if (equal? (cell-colwidth entry colnum) "")
|
|
'()
|
|
(list (list "WIDTH" (cell-colwidth entry colnum))))
|
|
(list (list "ALIGN" (cell-align entry colnum)))
|
|
(list (list "VALIGN" (cell-valign entry colnum))))
|
|
(if (empty-cell? entry)
|
|
(make entity-ref name: "nbsp")
|
|
(if (equal? (gi entry) (normalize "entrytbl"))
|
|
(process-node-list entry)
|
|
(process-node-list (children entry))))))))
|
|
|
|
;; EOF dbtable.dsl
|
|
|