← Back to branch summary

~ubuntu-branches/debian/sid/tk-html3/sid

« back to all changes in this revision

Viewing changes to src/tkhtml.tcl

  • Committer: Package Import Robot
  • Author(s): Ole Streicher
  • Date: 2012-03-02 18:45:00 UTC
  • Revision ID: package-import@ubuntu.com-20120302184500-np17d7d6gd1jedj0
Tags: upstream-3.0~fossil20110109
Import upstream version 3.0~fossil20110109

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/tkhtml.tcl
 
1
#
 
2
# tkhtml.tcl --
 
3
#
 
4
#     This file contains:
 
5
#
 
6
#         - The default bindings for the Html widget, and
 
7
#         - Some Tcl functions used by the stylesheet html.css.
 
8
#
 
9
# ------------------------------------------------------------------------
 
10
#
 
11
# Copyright (c) 2005 Eolas Technologies Inc.
 
12
# All rights reserved.
 
13
# 
 
14
# This Open Source project was made possible through the financial support
 
15
# of Eolas Technologies Inc.
 
16
# 
 
17
# Redistribution and use in source and binary forms, with or without
 
18
# modification, are permitted provided that the following conditions are met:
 
19
# 
 
20
#     * Redistributions of source code must retain the above copyright
 
21
#       notice, this list of conditions and the following disclaimer.
 
22
#     * Redistributions in binary form must reproduce the above copyright
 
23
#       notice, this list of conditions and the following disclaimer in the
 
24
#       documentation and/or other materials provided with the distribution.
 
25
#     * Neither the name of the <ORGANIZATION> nor the names of its
 
26
#       contributors may be used to endorse or promote products derived from
 
27
#       this software without specific prior written permission.
 
28
# 
 
29
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
 
30
# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 
31
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
 
32
# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
 
33
# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 
34
# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
 
35
# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
 
36
# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
 
37
# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
 
38
# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 
39
# POSSIBILITY OF SUCH DAMAGE.
 
40
#
 
41
 
 
42
switch -- $::tcl_platform(platform) {
 
43
  windows {
 
44
    bind Html <MouseWheel>   { %W yview scroll [expr %D/-30] units }
 
45
  }
 
46
  macintosh {
 
47
    bind Html <MouseWheel>   { %W yview scroll [expr %D*-4] units }
 
48
  }
 
49
  default {
 
50
    # Assume X windows by default.
 
51
    bind Html <ButtonPress-4>   { %W yview scroll -4 units }
 
52
    bind Html <ButtonPress-5>   { %W yview scroll  4 units }
 
53
  }
 
54
}
 
55
 
 
56
 
 
57
# Some Tcl procs used by html.css
 
58
#
 
59
namespace eval tkhtml {
 
60
 
 
61
    # This is called for <input type=text> tags that have a size
 
62
    # attribute. The size attribute in this case is supposed to be
 
63
    # the width in characters.
 
64
    proc inputsize_to_css {} {
 
65
        upvar N node
 
66
        set size [$node attr size]
 
67
        catch {
 
68
          if {$size < 0} {error "Bad value for size attribute"}
 
69
        }
 
70
 
 
71
        # Figure out if we are talking characters or pixels:
 
72
        switch -- [string tolower [$node attr -default text type]] {
 
73
          text     { 
 
74
            incr size [expr {int(($size/10)+1)}]
 
75
            set units ex 
 
76
          }
 
77
          password { 
 
78
            incr size [expr {int(($size/10)+1)}]
 
79
            set units ex 
 
80
          }
 
81
          file     { 
 
82
            incr size 10 
 
83
            set units ex 
 
84
          }
 
85
          default  { set units px }
 
86
        }
 
87
 
 
88
        return "${size}${units}"
 
89
    }
 
90
 
 
91
    proc if_disabled {if else} {
 
92
      upvar N node
 
93
      set disabled [$node attr -default 0 disabled]
 
94
      if {$disabled} {return $if}
 
95
      return $else
 
96
    }
 
97
    
 
98
    # The following two procs are used to determine the width and height of
 
99
    # <textarea> markups. Technically speaking, the "cols" and "rows"
 
100
    # attributes are compulsory for <textarea> elements.
 
101
    proc textarea_width {} {
 
102
        upvar N node
 
103
        set cols [$node attr -default "" cols]
 
104
        if {[regexp {[[:digit:]]+}] $cols} { return "${cols}ex" }
 
105
        return $cols
 
106
    }
 
107
    proc textarea_height {} {
 
108
        upvar N node
 
109
        set rows [$node attr -default "" rows]
 
110
        if {[regexp {[[:digit:]]+} $rows]} { return "[expr ${rows} * 1.2]em" }
 
111
        return $rows
 
112
    }
 
113
 
 
114
    proc size_to_fontsize {} {
 
115
        upvar N node
 
116
        set size [$node attr size]
 
117
 
 
118
        if {![regexp {([+-]?)([0123456789]+)} $size dummy sign quantity]} {
 
119
          error "not an integer"
 
120
        }
 
121
 
 
122
        if {$sign eq ""} {
 
123
            switch -- $quantity {
 
124
                1 {return xx-small}
 
125
                2 {return small}
 
126
                3 {return medium}
 
127
                4 {return large}
 
128
                5 {return x-large}
 
129
                6 {return xx-large}
 
130
                default { error "out of range: $size" }
 
131
            }
 
132
        }
 
133
 
 
134
        if {$sign eq "-"} {
 
135
            if {$quantity eq "1"} {return smaller}
 
136
            return "[expr 100 * pow(0.85, $quantity)]%"
 
137
        }
 
138
 
 
139
        if {$sign eq "+"} {
 
140
            if {$quantity eq "1"} {return larger}
 
141
            return "[expr 100 * pow(1.176, $quantity)]%"
 
142
        }
 
143
 
 
144
        error "logic error"
 
145
    }
 
146
 
 
147
    proc vscrollbar {base node} {
 
148
      set sb [scrollbar ${base}.vsb_[string map {: _} $node]]
 
149
      $sb configure -borderwidth 1 -highlightthickness 0 -command "$node yview"
 
150
      return $sb
 
151
    }
 
152
    proc hscrollbar {base node} {
 
153
      set sb [scrollbar ${base}.hsb_[string map {: _} $node] -orient horiz]
 
154
      $sb configure -borderwidth 1 -highlightthickness 0 -command "$node xview"
 
155
      return $sb
 
156
    }
 
157
 
 
158
    proc ol_liststyletype {} {
 
159
      switch -exact -- [uplevel {$N attr type}] {
 
160
        i {return lower-roman}
 
161
        I {return upper-roman}
 
162
        a {return lower-alpha}
 
163
        A {return upper-alpha}
 
164
        1 {return decimal}
 
165
      }
 
166
      error "Unrecognized type attribute on OL element"
 
167
    }
 
168
}
 
169