File: dbcallou.dsl

package info (click to toggle)
docbook-stylesheets 1.49-1
  • links: PTS
  • area: main
  • in suites: potato
  • size: 7,576 kB
  • ctags: 33
  • sloc: perl: 444; xml: 115; makefile: 98; sh: 27
file content (203 lines) | stat: -rw-r--r-- 6,850 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
;; $Id: dbcallou.dsl,v 1.5 1999/10/21 11:41:01 nwalsh Exp $
;;
;; This file is part of the Modular DocBook Stylesheet distribution.
;; See ../README or http://www.berkshire.net/~norm/dsssl/
;;

;; The support provided below is a little primitive because there's no way
;; to do line-addressing in Jade.
;;
;; CO's are supported with the CO element or, in SCREENCO and 
;; PROGRAMLISTINGCO only, AREAs.
;;
;; Notes on the use of AREAs:
;;
;; - Processing is very slow. Jade loops through each AREA for
;;   every column on every line.
;; - Only the LINECOLUMN units are supported, and they are #IMPLIED
;; - If a COORDS only specifies a line, the %callout-default-col% will
;;   be used for the column.
;; - If the column is beyond the end of the line, that will work OK, but
;;   if more than one callout has to get placed beyond the end of the same
;;   line, that doesn't work so well.
;; - Embedded tabs foul up the column counting.
;; - Embedded markup fouls up the column counting.
;; - Embedded markup with embedded line breaks fouls up the line counting.
;; - The callout bugs occur immediately before the LINE COLUMN specified.
;; - You can't point to an AREASET, that doesn't make any sense in HTML
;;   since it would imply a one-to-many link
;;
;; There's still no support for a stylesheet drawing the callouts on a
;; GRAPHIC, and I don't think there ever will be.
;;

(element areaspec (empty-sosofo))
(element area (empty-sosofo))
(element areaset (empty-sosofo))

(element co
  ($callout-mark$ (current-node) #t))

(element programlistingco (process-children))
(element screenco (process-children))
(element graphicco (process-children))

(element (screenco screen) 
  ($callout-verbatim-display$ %indent-screen-lines% %number-screen-lines%))

(element (programlistingco programlisting) 
  ($callout-verbatim-display$ %indent-programlisting-lines% 
			      %number-programlisting-lines%))

;; ----------------------------------------------------------------------

(define ($callout-bug$ conumber)
  (let ((number (if conumber (format-number conumber "1") "0")))
    (if conumber
	(if %callout-graphics%
	    (if (<= conumber %callout-graphics-number-limit%)
		(make empty-element gi: "IMG"
		      attributes: (list (list "SRC" 
					      (root-rel-path
					       (string-append
						%callout-graphics-path%
						number
						".gif")))
					(list "HSPACE" "0")
					(list "VSPACE" "0")
					(list "BORDER" "0")
					(list "ALT"
					      (string-append
					       "(" number ")"))))
		(make element gi: "B"
		      (literal "(" (format-number conumber "1") ")")))
	    (make element gi: "B"
		  (literal "(" (format-number conumber "1") ")")))
	(make element gi: "B"
	      (literal "(??)")))))

(define ($callout-mark$ co anchor?)
  ;; Print the callout mark for co
  (let* ((id (attribute-string (normalize "id") co))
	 (attr (if anchor?
		   (list (list "NAME" id))
		   (list (list "HREF" (href-to co))))))
    (make element gi: "A"
	  attributes: attr
	  (if (equal? (gi co) (normalize "co"))
	      ($callout-bug$ (if (node-list-empty? co)
				 #f
				 (child-number co)))
	      (let ((areanum (if (node-list-empty? co)
				 0
				 (if (equal? (gi (parent co)) (normalize "areaset"))
				     (absolute-child-number (parent co))
				     (absolute-child-number co)))))
		($callout-bug$ (if (node-list-empty? co)
				   #f
				   areanum)))))))

(define ($look-for-callout$ line col #!optional (eol? #f))
  ;; Look to see if a callout should be printed at line col, and print
  ;; it if it should
  (let* ((areaspec (select-elements (children (parent (current-node)))
				    (normalize "areaspec")))
	 (areas    (expand-children (children areaspec) 
				    (list (normalize "areaset")))))
    (let loop ((areanl areas))
      (if (node-list-empty? areanl)
	  (empty-sosofo)
	  (make sequence
	    (if ($callout-area-match$ (node-list-first areanl) line col eol?)
		($callout-area-format$ (node-list-first areanl) line col eol?)
		(empty-sosofo))
	    (loop (node-list-rest areanl)))))))

(define ($callout-area-match$ area line col eol?)
  ;; Does AREA area match line col?
  (let* ((coordlist (split (attribute-string (normalize "coords") area)))
	 (aline (string->number (car coordlist)))
	 (acol  (if (null? (cdr coordlist))
		    #f
		    (string->number (car (cdr coordlist)))))
	 (units (if (inherited-attribute-string (normalize "units") area)
		    (inherited-attribute-string (normalize "units") area)
		    (normalize "linecolumn"))))
    (and (equal? units (normalize "linecolumn"))
	 (or
	  (and (equal? line aline)
	       (equal? col acol))
	  (and (equal? line aline)
	       eol? 
	       (or (not acol) (> acol col)))))))

(define ($callout-area-format$ area line col eol?)
  ;; Format AREA area at the appropriate place
  (let* ((coordlist (split (attribute-string (normalize "coords") area)))
	 (aline (string->number (car coordlist)))
	 (acol  (if (null? (cdr coordlist))
		    #f
		    (string->number (car (cdr coordlist))))))
    (if (and (equal? line aline)
	     eol? 
	     (or (not acol) (> acol col)))
	(make sequence
	  (let loop ((atcol col))
	    (if (>= atcol (if acol acol %callout-default-col%))
		(empty-sosofo)
		(make sequence
		  (literal " ")
		  (loop (+ atcol 1)))))
	  ($callout-mark$ area #t))
	($callout-mark$ area #t))))

(define ($callout-verbatim-display$ indent line-numbers?)
  (let* ((content (make element gi: "PRE"
			attributes: (list
				     (list "CLASS" (gi)))
			($callout-verbatim-content$ indent line-numbers?))))
    (if %shade-verbatim%
	(make element gi: "TABLE"
	      attributes: ($shade-verbatim-attr$)
	      (make element gi: "TR"
		    (make element gi: "TD"
			  content)))
	content)))

(define ($callout-verbatim-content$ indent line-numbers?)
  ;; Print linespecific content in a callout with line numbers
  (make sequence
    ($line-start$ indent line-numbers? 1)
    (let loop ((kl (children (current-node)))
	       (linecount 1)
	       (colcount 1)
	       (res (empty-sosofo)))
      (if (node-list-empty? kl)
	  res
	  (loop
	   (node-list-rest kl)
	   (if (char=? (node-property 'char (node-list-first kl)
				      default: #\U-0000) #\U-000D)
	       (+ linecount 1)
	       linecount)
	   (if (char=? (node-property 'char (node-list-first kl)
				      default: #\U-0000) #\U-000D)
	       1
	       (if (char=? (node-property 'char (node-list-first kl)
					  default: #\U-0000) #\U-0000)
		   colcount
		   (+ colcount 1)))
	   (let ((c (node-list-first kl)))
	     (if (char=? (node-property 'char c default: #\U-0000) 
			 #\U-000D)
		 (sosofo-append res
				($look-for-callout$ linecount colcount #t)
				(process-node-list c)
				($line-start$ indent 
					      line-numbers?
					      (+ linecount 1)))
		 (sosofo-append res 
				($look-for-callout$ linecount colcount)
				(process-node-list c)))))))))

;; EOF dbcallout.dsl