DELETED base64.tcl Index: base64.tcl ================================================================== --- base64.tcl +++ /dev/null @@ -1,16 +0,0 @@ -proc B64encode {str {len -1}} { - set base64digits \ - "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" - binary scan $str B* bits - if {$len < 0} { - set len [string length $bits] - } - set result {} - for {set i 0} {$i<$len} {incr i 6} { - binary scan [binary format B8 \ - 00[string range $bits $i [expr {$i+5}]]0000] c mybits - append result [string index $base64digits $mybits] - } - while {[string length $result] % 4} {append result =} - return $result -} ADDED bin/cvsupdate.tcl Index: bin/cvsupdate.tcl ================================================================== --- /dev/null +++ bin/cvsupdate.tcl @@ -0,0 +1,13 @@ +#! /bin/sh + +# Brings local copy of CVS archive up-to-date. \ +exec /home/fellowsd/arch/sparc-sun-solaris/bin/tclsh8.0 "$0" -- ${1+"$@"} + +set SRCDIR [file join [pwd] [file dirname [info script]]] +source $SRCDIR/config.tcl +set EDITDIR $DOCDIR +source $SRCDIR/cvs.tcl + +set code [catch {cvs -z9 update} msg] +if {[string length [string trim $msg]]} {puts $msg} +exit $code ADDED bin/mailnote.tcl Index: bin/mailnote.tcl ================================================================== --- /dev/null +++ bin/mailnote.tcl @@ -0,0 +1,94 @@ +#! /bin/sh +# \ +exec tclsh "$0" ${1+"$@"} + +### READ STANDARD CONFIG ### +set SRCDIR [file join [pwd] [file dir $argv0]] +source $SRCDIR/config.tcl + +### NEW GLOBALS WITH POSSIBLE VALUES ### + +# NOTIFYDB = [file join [file dir $LOGFILE] notify.db] +# ID = /usr/bin/id +# MAILX = /usr/bin/mailx +# WEBEDITID = tclhttpd +# NOTIFYURL = ${BASEURL}notify.html + +### HELPER PROCEDURES ### +proc readNotifyDB {} { + # NB This procedure needs some kind of locking protocol... + + global NOTIFYDB + set fid [open $NOTIFYDB r] + set lines [read $fid] + close $fid + return $lines +} +proc readLogMessage {} { + set lines {} + set readlog 0 + while {[gets stdin line]} { + if {$readlog} { + lappend lines $line + } else { + set readlog [string match "Log Message:" $line] + } + } + return [join $lines "\n"] +} +proc getUserID {} { + global ID + if {[regexp {uid=[0-9]+\([a-zA-Z0-9_]+\)} [exec $ID] -> id]} { + return $id + } else { + return "unknown user" + } +} +proc mail {address subject args} { + global MAILX + set body [join $args "\n\n"] + exec $MAILX -s $subject $address << "$body\n" +} + +### IMPLEMENTATION ### + +# Read this first; probably ought to add some kind of locking mechanism. +set notifylines [readNotifyDB] + +set logmsg [readLogMessage] + +set id [getUserID] +if {![string compare $id $WEBEDITID]} { + set mod "Modified over the web (see log message)" +} else { + set mod "Modified by: $id" +} + +# changed($file) exists if $file was changed +array set changed {} +foreach file $argv { + set changed($file) $file +} + +foreach line [split $notifylines "\n"] { + if {[regexp "^(\[0-9\]+)\[ \t\]+(.*@.*)" $line -> tip mail]} { + catch { + # if $email didn't want to be notified about any of the + # files mentioned in this log notification, then the + # reading of changed($tip.tip) will fail + mail $mail "\[TIP Archive] $changed($tip.tip) modified" \ + "TIP #$tip has been modified, and you might wish to\ + check it out.\n $BASEURL$tip.html" "To remove your\ + email address from the notification list for this\ + TIP,\nvisit the page, confirm your email address and\ + select 'Remove':\n $NOTIFYURL?tip=$tip,email=$mail" \ + "Log message associated with the update is as\ + follows:\n$logmsg" + } + } elseif {[regexp {^\*(.*@.*)} $line -> mail]} { + mail $mail "\[TIP Archive] update done" "Files modified: $argv\n$mod"\ + "Log message:\n$logmsg" + } +} + +exit ADDED bin/makeconfig.tcl Index: bin/makeconfig.tcl ================================================================== --- /dev/null +++ bin/makeconfig.tcl @@ -0,0 +1,340 @@ +#! /bin/sh +# Re-execute using wish \ +exec wish "$0" $* + + +### ATTEMPT TO LOAD PREVIOUSLY-CREATED VERSION AND SET UP SRCDIR VAR ### +set SRCDIR [file join [pwd] [file dir $argv0]] +regsub -all {/\./} $SRCDIR / SRCDIR +regsub -all {/\.$} $SRCDIR {} SRCDIR + +namespace eval configure { + variable conffile [file join $::SRCDIR config.tcl] + variable deffile [file join $::SRCDIR conf_def.tcl] + variable showall \ + [expr {[string compare [lindex $::argv 0] "-expert"] == 0}] + + variable variables {} + variable optional {} + variable pages {} + variable header {} + variable introMessage {} + variable postUserScript {} +} + +puts "Loading old configuration: $::configure::conffile" +catch {source $::configure::conffile} + +puts "Loading setup: $::configure::deffile" +source $::configure::deffile + +namespace eval configure { + namespace export runGUI writeConfig + + variable name + set name() $introMessage + variable kinds + set kinds() message + + ### HELPER PROCEDURES ### + proc selectColour {var} { + variable name + upvar #0 $var colourVar + set col [tk_chooseColor -parent .t -initialcolor $colourVar \ + -title $name($var)] + if {[string length $col]} { + set colourVar $col + } + } + proc selectFile {var} { + variable name + upvar #0 $var fileVar + set file [tk_getOpenFile -parent .t -initialdir [file dir $fileVar] \ + -title $name($var)] + if {[string length $file]} { + set fileVar $file + } + } + proc selectDir {var} { + variable name + upvar #0 $var dirVar + set dir [tk_chooseDirectory -parent .t -initialdir $dirVar \ + -title $name($var) -mustexist 1] + if {[string length $dir]} { + set dirVar $dir + } + } + + ### BALLOON HELP ### + proc balloonIn {w msg} { + if {![winfo exist .balloon]} { + toplevel .balloon + wm overrideredirect .balloon 1 + label .balloon.l -foreground blue -background yellow \ + -highlightthick 0 -relief solid -borderwidth 1 \ + -font {Helvetica -10} -textvariable ::configure::balloon + pack .balloon.l + } + variable balloon $msg + set x [expr {[winfo rootx $w]+10}] + set y [expr {[winfo rooty $w]+[winfo height $w]+5}] + set g [format +%d+%d $x $y] + wm geometry .balloon $g + wm deiconify .balloon + wm geometry .balloon $g + raise .balloon + after idle "[list wm geometry .balloon $g]; raise .balloon" + } + proc balloonOut {} { + if {[winfo exist .balloon]} { + wm withdraw .balloon + } + } + proc bindBalloon {msg r args} { + foreach w $args { + bind $w [namespace code [list balloonIn $r $msg]] + bind $w [namespace code balloonOut] + } + } + + ### HANDLE THE GUI FOR A SINGLE EDITING PAGE ### + proc displayPage {pagedesc first last} { + variable forwardback + variable kinds + variable name + variable showall + + toplevel .t + wm title .t [lindex $pagedesc 0] + wm geometry .t +80+80 + set i 0 + set serif {Times 14} + set sans {Helvetica 14} + set ss {Helvetica 10 bold} + set mono {Courier 10} + set bold {Helvetica 18 bold} + set focusmagic {} + + set havedirb [llength [info command tk_chooseDirectory]] + set havespin [llength [info command spinbox]] + + foreach var [lrange $pagedesc 1 end] { + set kind $kinds($var) + switch $kind { + message {#ignore} + dir { + if {$havedirb} { + set msg "Please choose a directory (you can use the\ + button at the right to summon a directory\ + browser.)" + } else { + set msg "Please choose a directory." + set kind string + } + } + file { + set msg "Please choose a file (you can use the\ + button at the right to summon a file browser.)" + } + color - colour { + set msg "Please choose a $kind (you can use the button\ + at the right to summon a $kind browser.)" + } + string { + set msg "Input a string value here." + } + number { + set msg "Input a numeric value here." + if {!$havespin} {set kind string} + } + boolean { + set msg "Click here to toggle this feature on or off." + } + } + if {$showall && [string length $var]} { + set msg "Variable: $var" + } + switch $kind { + message { + pack [message .t.m$i -text $name($var) -font $serif \ + -anchor w] -fill x -expand 1 + bind .t [list .t.m$i configure -width %w] + } + dir { + lappend focusmagic .t.f$i.e + label .t.l$i -text $name($var) -anchor w -font $serif + pack .t.l$i [frame .t.f$i] -fill x -expand 1 + entry .t.f$i.e -textvariable $var -bg white -font $mono + button .t.f$i.b -text "Browse" -font $ss -takefocus 0 \ + -command [list selectDir $var] -padx 2 -pady 0 + pack .t.f$i.e .t.f$i.b -fill both -side left + pack configure .t.f$i.e -expand 1 + bindBalloon $msg .t.f$i .t.l$i .t.f$i.e .t.f$i.b + } + file { + lappend focusmagic .t.f$i.e + label .t.l$i -text $name($var) -anchor w -font $serif + pack .t.l$i [frame .t.f$i] -fill x -expand 1 + entry .t.f$i.e -textvariable $var -bg white -font $mono + button .t.f$i.b -text "Browse" -font $ss -takefocus 0 \ + -command [list selectFile $var] -padx 2 -pady 0 + pack .t.f$i.e .t.f$i.b -fill both -side left + pack configure .t.f$i.e -expand 1 + bindBalloon $msg .t.f$i .t.l$i .t.f$i.e .t.f$i.b + } + color - colour { + lappend focusmagic .t.f$i.e + label .t.l$i -text $name($var) -anchor w -font $serif + pack .t.l$i [frame .t.f$i] -fill x -expand 1 + entry .t.f$i.e -textvariable $var -bg white -font $mono + button .t.f$i.b -text "Browse" -font $ss -takefocus 0 \ + -command [list selectColour $var] -padx 2 -pady 0 + pack .t.f$i.e .t.f$i.b -fill both -side left + pack configure .t.f$i.e -expand 1 + bindBalloon $msg .t.f$i .t.l$i .t.f$i.e .t.f$i.b + } + string { + lappend focusmagic .t.e$i + label .t.l$i -text $name($var) -anchor w -font $serif + entry .t.e$i -textvariable $var -bg white -font $mono + pack .t.l$i .t.e$i -fill x -expand 1 + bindBalloon $msg .t.e$i .t.l$i .t.e$i + } + number { + lappend focusmagic .t.e$i + label .t.l$i -text $name($var) -anchor w -font $serif + spinbox .t.e$i -textvariable $var -bg white -font $mono + pack .t.l$i .t.e$i -fill x -expand 1 + bind .t.e$i [list incr $var] + bind .t.e$i [list incr $var -1] + bindBalloon $msg .t.e$i .t.l$i .t.e$i + } + boolean { + lappend focusmagic .t.b$i + pack [checkbutton .t.b$i -text $name($var) -anchor w \ + -font $sans -variable $var] -fill x -expand 1 + bindBalloon $msg .t.b$i .t.b$i + } + } + incr i + } + pack [frame .t.bottom] -expand 1 -fill both + button .t.bottom.left -text "<< Back" -font $bold -default normal \ + -command {set ::configure::forwardback -1} + if {$first} { + .t.bottom.left configure -state disabled -font $bold + bind .t {set ::configure::forwardback 0} + } else { + bind .t {set ::configure::forwardback -1} + } + button .t.bottom.middle -text "Cancel" -font $bold -default normal \ + -command {set ::configure::forwardback 0} + button .t.bottom.right -text "Next >>" -font $bold -default active \ + -command {set ::configure::forwardback 1} + if {$last} { + .t.bottom.right configure -text "Write Config" + } + pack .t.bottom.left .t.bottom.middle .t.bottom.right \ + -expand 1 -fill both -side left + bind .t.bottom {set ::configure::forwardback 0} + bind .t {set ::configure::forwardback 1} + if {[string length $focusmagic]} { + focus [lindex $focusmagic 0] + } else { + focus .t.bottom.right + } + vwait ::configure::forwardback + if {[winfo exist .t.bottom]} { + bind .t.bottom {} + destroy .t + } + return $forwardback + } + + ### RUN THE CONFIGURATION GUI ### + proc runGUI {} { + variable showall + variable kinds + variable variables + variable optional + variable pages + variable name + + set pageidx 0 + set step 1 + array set defs {} + while {$step && $pageidx>=0} { + foreach {var kind val doc} $variables { + set name($var) $doc + set dynamic [regexp {[\[$]} $val] + if {$dynamic || ![info exist ::$var]} { + if {$dynamic} { + set defs($var) $val + } + set ::$var [uplevel #0 [list subst $val]] + } + set kinds($var) $kind + } + + while {$pageidx < [llength $pages]} { + set page [lindex $pages $pageidx] + foreach var [lrange $page 1 end] { + if {[string length $var] && [info exist defs($var)]} { + set ::$var [uplevel #0 [list subst $defs($var)]] + #puts "$var = [set ::$var]" + } + } + if {$showall || [lsearch $optional [lindex $page 1]]<0} { + set step [displayPage $page [expr {$pageidx==0}] \ + [expr {$pageidx==[llength $pages]-1}]] + } + if {!$step} { + return 0 + } + incr pageidx $step + } + set done 1 + foreach {var ? ? ?} $variables { + if {![string length [set ::$var]]} { + tk_messageBox -type ok -icon error \ + -title "Missing value" \ + -message "You must supply a value for all fields" + set done 0 + set pageidx 1 + set step 1 + break + } + } + if {$done} {break} + } + + return [expr {$step > 0}] + } + + ### WRITE THE NEW VERSION OF THE CONFIGURATION FILE ### + proc writeConfig {} { + variable conffile + variable variables + variable header + + set fid [open $conffile w] + foreach line [split $header "\n"] { + puts $fid [string trimleft $line] + } + foreach {var ? ? ?} $variables { + puts $fid [list set $var [set ::$var]] + } + close $fid + } +} + +### TOP LEVEL CODE ### +wm withdraw . +if {[configure::runGUI]} { + eval $configure::postUserScript + puts "Writing new configuration: $::configure::conffile" + configure::writeConfig +} else { + puts "Cancelled; $::configure::conffile unchanged" +} +exit ADDED bin/postnews.tcl Index: bin/postnews.tcl ================================================================== --- /dev/null +++ bin/postnews.tcl @@ -0,0 +1,192 @@ +#! /bin/sh +#\ +exec tclsh "$0" ${1+"$@"} + +set SRCDIR [file join [pwd] [file dirname $argv0]] +source $SRCDIR/config.tcl +source $SRCDIR/parse.tcl +source $SRCDIR/md5.tcl +source $SRCDIR/base64.tcl +source $SRCDIR/post.tcl +source $SRCDIR/mail.tcl + +binary scan [binary format f [pid].[clock seconds]] I uniquePart + +proc MD5inB64 {str} { + return [B64encode [md5pure::md5 $str] 128] +} + +proc generateNewsMessage {tipnumber extra} { + global DOCDIR PUBLISHURL FEATURE FOOTERTEXT ENGINEURL TCLCOREMAIL + global opts uniquePart + set tipfile [file join $DOCDIR $tipnumber.tip] + set docurl $PUBLISHURL/$tipnumber.html + set editurl $PUBLISHURL/edit/$tipnumber + + puts stderr "Loading TIP from $tipfile" + array set h [getTIPDetails $tipfile] + set tip [getTIPFileContents $tipfile] + + puts stderr "Generating plain text body" + if {$FEATURE(EDIT_URL_IN_NEWS_MESSAGE)} { + set body [formatTIPDocument $tip txt URL $docurl WebEdit $editurl] + } else { + set body [formatTIPDocument $tip txt URL $docurl] + } + + puts stderr "Generating body md5 digest" + set digest [MD5inB64 $body] + + puts stderr "Generating headers" + append content \ + "MIME-Version: 1.0\n" \ + "Content-Type: text/plain; charset=iso-8859-1\n" \ + "Content-Transfer-Encoding: 8bit\n" \ + "Content-MD5: $digest\n" + append content [clock format [clock seconds] -gmt 1 -format \ + "Date: %a, %d %b %Y %H:%M:%S +0000\n"] + append content [format "Message-Id: \n" \ + $tipnumber $uniquePart [info hostname]] + if {[llength $extra]} { + append content "Subject: [join $extra] TIP #$h(TIP): $h(Title)\n" + } else { + append content "Subject: TIP #$h(TIP): $h(Title)\n" + } + regsub -all "\t" [lindex $h(Author) 0] " " a0 + regsub {^(.*[.].*[^ ]) +<(.+)>$} $a0 {"\1" <\2>} a0 + append content \ + "Sender: TIP Editor \n" \ + "From: [string trim $a0]\n" \ + "Errors-To: donal.fellows@man.ac.uk\n" + if {$opts(news)} { + append content \ + "Newsgroups: comp.lang.tcl,comp.lang.tcl.announce\n" \ + "To: tcl-announce@mitchell.org\n" \ + "Reply-To: [string trim $a0]\n" \ + "Followup-To: comp.lang.tcl\n" + # Some software seems to insist on sending email messages to + # me in response to TIPs; this is just about as bogus as you + # can get. However, mail in general provides no way to say + # that you want administrative stuff going to one address, + # and subject-matter related stuff going to another. This + # sucks... + ###append content "Reply-To: $TCLCOREMAIL\n" + set opts(news) 0 + } elseif {$opts(list)} { + append content \ + "To: $TCLCOREMAIL\n" \ + "Reply-To: $TCLCOREMAIL\n" + set opts(list) 0 + if {$opts(author)} { + set opts(author) 0 + foreach author $h(Author) { + regsub {^(.*[.].*[^ ]) +<(.+)>$} $author {"\1" <\2>} author + append content "Cc: $author\n" + } + } + foreach extraAddress $opts(extra) { + append content "Cc: $extraAddress\n" + } + set opts(extra) {} + } elseif {$opts(author)} { + set opts(author) 0 + foreach author $h(Author) { + regsub {^(.*[.].*[^ ]) +<(.+)>$} $author {"\1" <\2>} author + append content "To: $author\n" + } + foreach extraAddress $opts(extra) { + append content "Cc: $extraAddress\n" + } + set opts(extra) {} + } + append content \ + "Organization: Tcl Core Team\n" \ + "X-Generated-By: $FOOTERTEXT\n" \ + "X-Generator-Url: $ENGINEURL\n" + if {[info exist h(Keywords)]} { + append content "Keywords: [join $h(Keywords) {, }]\n" + } + append content "\n" $body + + puts stderr "Posting message" + return $content +} + +if {!$FEATURE(PUBLISHING)} { + puts stderr "Sorry, but this installation does not support\ + publishing of TIPs" + exit 1 +} + +proc preset {ary name value} { + upvar $ary a + if {![info exist a($name)]} { + set a($name) $value + } +} +proc shift {{n 1}} { + global argv + set shifted [lrange $argv 0 [expr $n-1]] + set argv [lrange $argv $n end] + return $shifted +} + +proc main {} { + global argc argv opts argv0 TCLCOREMAIL + if {$argc == 0} { + puts stderr "usage: [file tail $argv0] ?options? ?--? tipNumber" + puts stderr "Supported options are:" + puts stderr "\t-news\t Posts to comp.lang.tcl and comp.lang.tcl.announce" + puts stderr "\t-list\t Posts to $TCLCOREMAIL mailing list." + puts stderr "\t-author\t Sends a copy to the (first) author of the TIP." + puts stderr "\t-extra address" + puts stderr "\t\t Sends the publishing message to an extra email address" + puts stderr "\t\t (e.g. a mailing list where people have a special interest" + puts stderr "\t\t in the TIP.) Multiple extra email addresses can be" + puts stderr "\t\t specificied by using this option mulktiple times." + puts stderr "\t-test\t Prevent all posting/mailing and prints formatted on" + puts stderr "\t\t standard output (for debugging.)" + puts stderr "\t--\t Marks the end of the options." + exit + } + array set opts {} + while {[llength $argv]} { + switch -- [lindex $argv 0] { + -news {set opts(news) 1} + -list {set opts(list) 1} + -author {set opts(author) 1} + -test {set opts(test) 1} + -- {shift; break} + -extra { + shift + lappend opts(extra) [lindex $argv 0] + } + default {break} + } + shift + } + if {![array size opts]} { + array set opts { + news 1 list 1 author 1 test 0 extra {} + } + } else { + preset opts news 0 + preset opts list 0 + preset opts author 0 + preset opts test 0 + preset opts extra {} + } + + while {[lsearch [array get opts] 1] >= 0} { + set message [generateNewsMessage [lindex $argv 0] [lrange $argv 1 end]] + if {$opts(test)} { + puts $message + set opts(test) 0 + break + } else { + mail::mailsend $message 1 + } + } +} +main +exit ADDED bin/quicktip.tcl Index: bin/quicktip.tcl ================================================================== --- /dev/null +++ bin/quicktip.tcl @@ -0,0 +1,223 @@ +#! /usr/local/bin/tclsh8.0 + +# Regular expressions - suitable for 8.0 as well as later. +set ws "\[ \t\n\]" +set ParSepRE "^$ws*$" +set ItemNoLeadRE "^\[^ \t>\]" +set ItemLeadRE "^$ws*((>$ws+)*)(\\*|\[0-9\]+\\.|\[^\t\n:\]+:)$ws" +set ItemContRE "^($ws+>)+$ws*" +set EmailRE {<([^<>@]+@[^<>@]+)>} +# It took lots of experiment to develop this next RE... +set URLRE {(https?|ftp|news(rc)?|mailto|gopher):[-A-Za-z0-9/_:.#+@?=&;~\\]+} + +# ---------------------------------------------------------------------- + +proc splitIntoParagraphs {string} { + global ParSepRE + set paragraphs {} + set current {} + foreach line [split $string "\n"] { + if {[regexp $ParSepRE $line]} { + # (VISUALLY) BLANK LINE = PARAGRAPH SEPARATOR + if {[string length $current]} { + lappend paragraphs [string trim $current "\n"] + set current {} + } + continue + } + append current "\n$line" + } + if {[string length $current]} { + lappend paragraphs [string trim $current "\n"] + } + return $paragraphs +} + +proc shortspc {string} { + global ws + regsub -all ${ws}+ $string " " string + return $string +} +proc intuitParagraphKind {paragraph} { + switch -glob -- $paragraph { + ~* { + set content [string range $paragraph 1 end] + return [list section [string trim [shortspc $content]]] + } + |* { + set lines {} + foreach line [split $paragraph "\n"] { + if {![string match |* $line]} { + return -code error "malformatted verbatim line \"$line\"" + } + lappend lines [string range $line 1 end] + } + return [list verbatim $lines] + } + #index:* { + set type [string trim [string range $paragraph 7 end]] + if {![string length $type]} {set type medium} + return [list index $type] + } + #image:* { + return [list image [string range $paragraph 7 end]] + } + ---- { + return {separator} + } + } + + global ItemNoLeadRE ItemLeadRE ItemContRE + + # Hmm. Need to figure out if we've got a list item of some kind. + if {[regexp $ItemNoLeadRE $paragraph]} { + return [list ordinary [shortspc $paragraph]] + } + if {[regexp $ItemLeadRE $paragraph head continuation ? kind]} { + set content [string range $paragraph [string length $head] end] + set level [llength $continuation] + switch -glob -- $kind { + *: { + set kind [string trimright $kind ":"] + return [list description $kind $level [shortspc $content]] + } + *. { + set kind [string trimright $kind "."] + return [list enumeration $kind $level [shortspc $content]] + } + } + return [list bulleting $level [shortspc $content]] + } + if {[regexp $ItemContRE $paragraph head]} { + set content [string range $paragraph [string length $head] end] + return [list continuation [llength $head] [shortspc $content]] + } + return [list ordinary [shortspc $paragraph]] +} + +# ---------------------------------------------------------------------- + +namespace eval tiphtml { + variable curlev -1 + variable contexts {} + proc enterlistcontext {level good bad1 bad2} { + variable curlev + variable contexts + if {$level > $curlev} { + incr curlev + lappend contexts "" + puts -nonewline "<$good compact>" + } + switch [lindex $contexts end] "" - "" { + puts -nonewline [lindex $contexts end] + puts -nonewline "<$good compact>" + set contexts [lreplace $contexts end end ""] + } + } + proc closecontext {{level -1}} { + variable curlev + variable contexts + while {$level < $curlev} { + incr curlev -1 + puts -nonewline [lindex $contexts end] + set contexts [lrange $contexts 0 [expr {[llength $contexts]-2}]] + } + } + proc quoteLiteral {string} { + # This would be better with [string map], but that's not in 8.0 + regsub -all & $string {\&} string + regsub -all < $string {\<} string + regsub -all > $string {\>} string + regsub -all \" $string {\"} string + return $string + } + + proc section {title} { + closecontext + puts "

[quoteLiteral $title]

" + } + proc ordinary {string} { + continuation -1 $string + } + proc bulleting {level body} { + closecontext $level + enterlistcontext $level ul ol dl + puts -nonewline "
  • " + continuation $level $body + } + proc description {tag level body} { + closecontext $level + enterlistcontext $level dl ol ul + puts -nonewline "
    $tag
    " + continuation $level $body + } + proc enumeration {tag level body} { + closecontext $level + enterlistcontext $level ol dl ul + if {$tag != 1} { + puts -nonewline "
  • " + } else { + puts -nonewline "
  • " + } + continuation $level $body + } + proc continuation {level body} { + global EmailRE URLRE + closecontext $level + regsub -all $EmailRE $body "\x81mailto:\\1\x82" body + set body [quoteLiteral $body] + + regsub -all $URLRE $body "&" body + + regsub -all {''(('?[^'])+)''} $body "\\1" body + regsub -all \x81 $body "\\<" body + regsub -all \x82 $body "\\>" body + variable curlev + if {$curlev==-1 && $level==1} { + puts "

    $body

    " + } else { + puts "

    $body

    " + } + } + proc separator {} { + closecontext + puts "
    " + } + proc verbatim {lines} { + puts "
    "
+	foreach line $lines {
+	    # HTML ignores formfeed chars, but we want to see them...
+	    regsub -all {} [quoteLiteral $line] "^L" line
+	    puts $line
+	}
+	puts -nonewline "
    " + } + + proc index {kind} { + closecontext + puts "

    Index\ + style \"$kind\" not yet supported!

    " + } + proc image {bodytext} { + closecontext + puts "

    Image\ + \"$bodytext\" not yet supported!

    " + } + proc generateHTMLPars {body} { + foreach par [splitIntoParagraphs $body] { + eval [intuitParagraphKind $par] + } + } +} + +# ---------------------------------------------------------------------- + +if {[llength $argv]} { + foreach arg $argv { + set f [open $arg] + tiphtml::generateHTMLPars [read $f] + close $f + } +} else { + tiphtml::generateHTMLPars [read stdin] +} ADDED bin/stats.bybrowser.tcl Index: bin/stats.bybrowser.tcl ================================================================== --- /dev/null +++ bin/stats.bybrowser.tcl @@ -0,0 +1,48 @@ +#! /bin/sh +# \ +exec tclsh8.0 $0 ${1+"$@"} + +#awk '{$1=$2=$3=""; print}' ../TIP/log | sort | uniq -c | sort -n +#echo --------------------------- +#awk '{$1=$2=$3=""; print}' ../TIP/log | perl -ne 'do {print "IE\n"; next;} if /MSIE/; do {print "Netscape\n"; next;} if /Mozilla/; print "Other\n";' | sort | uniq -c | sort -n + +set SRCDIR [file join [pwd] [file dirname [info script]]] +source $SRCDIR/config.tcl + +set browsers {} +array set browsermap {} + +set f [open $LOGFILE r] +while {[gets $f line] >= 0} { + foreach {ip date name browser} [split $line "\t"] {break} + regsub -all {[ ]+} [string trim $browser] " " browser + append browsermap($browser) . +} +close $f + +foreach {name str} [array get browsermap] { + lappend browsers [list [string length $str] $name] +} +unset browsermap +array set browsermap {IE 0 Netscape 0 Other 0} + +foreach line [lsort -integer -index 0 $browsers] { + foreach {count browser} $line {} + puts [format "%6d %s" $count $browser] + switch -glob -- $browser { + *MSIE* {incr browsermap(IE) $count} + *Mozilla* {incr browsermap(Netscape) $count} + default {incr browsermap(Other) $count} + } +} +puts --------------------------- +set browsers {} +foreach {class count} [array get browsermap] { + lappend browsers [list $count $class] +} +foreach line [lsort -integer -index 0 $browsers] { + foreach {count class} $line {} + puts [format "%6d %s" $count $class] +} + +exit 0 ADDED bin/stats.bydomain.tcl Index: bin/stats.bydomain.tcl ================================================================== --- /dev/null +++ bin/stats.bydomain.tcl @@ -0,0 +1,51 @@ +#! /bin/sh +# \ +exec tclsh8.0 $0 ${1+"$@"} + +set SRCDIR [file join [pwd] [file dirname [info script]]] +source $SRCDIR/config.tcl + +set ips {} +array set ipmap {} +set threshold 0 +if {[llength $argv]} { + set threshold [lindex $argv 0] +} + +set f [open $LOGFILE r] +while {[gets $f line] >= 0} { + foreach {ip date name browser} [split $line "\t"] {break} + append ipmap([string trim $ip]) . +} +close $f + +set NUMRE {([0-9]?[0-9]?[0-9])} +set DQRE "^$NUMRE\.$NUMRE\.$NUMRE\.$NUMRE$" + +foreach {ip str} [array get ipmap] { + set len [string length $str] + set domain numeric/unknown + if {$len > $threshold} { + set host $ip + catch { + set host [lindex [lindex [split [exec host $ip] "\n"] 0] 1] + if {![regexp $DQRE $host]||$a>255||$b>255||$c>255||$d>255} { + set domain [join [lrange [split $host .] 1 end] .] + } + } + } + append dommap($domain) $str +} +unset ipmap + +foreach {domain str} [array get dommap] { + lappend ips [list [string length $str] $domain] +} +unset dommap + +foreach line [lsort -integer -index 0 $ips] { + foreach {count domain} $line {} + puts [format "%6d %s" $count $domain] +} + +exit 0 ADDED bin/stats.byfile.tcl Index: bin/stats.byfile.tcl ================================================================== --- /dev/null +++ bin/stats.byfile.tcl @@ -0,0 +1,30 @@ +#! /bin/sh +# \ +exec tclsh8.0 $0 ${1+"$@"} + +#awk '{print $3}' ../TIP/log | sort | uniq -c | sort -n + +set SRCDIR [file join [pwd] [file dirname [info script]]] +source $SRCDIR/config.tcl + +set files {} +array set filemap {} + +set f [open $LOGFILE r] +while {[gets $f line] >= 0} { + foreach {ip date name browser} [split $line "\t"] {break} + append filemap([string trim $name]) . +} +close $f + +foreach {name str} [array get filemap] { + lappend files [list [string length $str] $name] +} +unset filemap + +foreach line [lsort -integer -index 0 $files] { + foreach {count file} $line {} + puts [format "%6d %s" $count $file] +} + +exit 0 ADDED bin/stats.byip.tcl Index: bin/stats.byip.tcl ================================================================== --- /dev/null +++ bin/stats.byip.tcl @@ -0,0 +1,39 @@ +#! /bin/sh +# \ +exec tclsh8.0 $0 ${1+"$@"} + +#awk '{print $1}' ../TIP/log | sort | uniq -c | sort -n + +set SRCDIR [file join [pwd] [file dirname [info script]]] +source $SRCDIR/config.tcl + +set ips {} +array set ipmap {} +set threshold 0 +if {[llength $argv]} { + set threshold [lindex $argv 0] +} + +set f [open $LOGFILE r] +while {[gets $f line] >= 0} { + foreach {ip date name browser} [split $line "\t"] {break} + append ipmap([string trim $ip]) . +} +close $f + +foreach {ip str} [array get ipmap] { + lappend ips [list [string length $str] $ip] +} +unset ipmap + +foreach line [lsort -integer -index 0 $ips] { + foreach {count host} $line {} + if {$count > $threshold} { + catch { + set host [lindex [lindex [split [exec host $host] "\n"] 0] 1] + } + } + puts [format "%6d %s" $count $host] +} + +exit 0 ADDED bin/tip.tcl Index: bin/tip.tcl ================================================================== --- /dev/null +++ bin/tip.tcl @@ -0,0 +1,686 @@ +#! /usr/local/bin/tclsh8.0 + +set ThisFilename [file join [pwd] [info script]] +while {![string compare [file type $ThisFilename] link]} { + # This is a symlink! + set ThisFilename [file join [file dirname $ThisFilename] \ + [file readlink $ThisFilename]] +} +set SRCDIR [file dirname $ThisFilename] +source $SRCDIR/config.tcl + +# This is *not* configurable because changing it can require many other +# changes to be made throughout the rest of the TIP suite. It is also +# not used outside this file. +set DOCTYPE "" +set DOCTYPE_FRAMES "" + +# Get the time when a file was last modified, in the format used by +# webservers (apparently.) +proc lastModTime {filename} { + # Removed day-of-week spec (which is written in by the + # webserver instead) but am not using %T since that is + # not universally supported - DKF + return [clock format [file mtime $filename] \ + -format "%d %B %Y %H:%M:%S GMT" -gmt 1] +} +# MH recommends a different format for Expires headers - DGP +proc expireTime {filename} { + # %T -> %H:%M:%S (see above) DKF + return [clock format [file mtime $filename] \ + -format "%a, %d %b %Y %H:%M:%S GMT" -gmt 1] +} + +proc gendoc {filename kind} { + global contenttypes + + # Head off the most common kind of "probing" error + if {![file readable $filename]} { + return -code error "File unreadable or non-existant" + } + + set f [open $filename r] + set d [read $f [file size $filename]] + close $f + + if {![string compare $kind .htm]} { + set kind .html + } + set data [formatTIPDocument $d [string trim $kind .]] + array set info [getTIPDetails $filename] + + puts "Content-Type: $contenttypes($kind)" + if {[info exist info(Keywords)]} { + puts "Keywords: [file join $info(Keywords) {, }]" + } + # Assume we can get away with this... + puts "Content-Length: [string length $data]" + # Active TIPs must always be regenerated from source, so we cannot + # supply a date of last modification. This is because they might + # format differently despite the source remaining unchanged. + if {[string compare $info(State) Active]} { + puts "Last-Modified: [lastModTime $filename]" + puts "Expires: [expireTime $filename]" + puts "Cache-Control: no-cache, must-revalidate" + puts "Pragma: no-cache" + } + puts "" + puts -nonewline $data +} + +proc transferraw {filename kind} { + global contenttypes + + # Head off the most common kind of "probing" error + if {![file readable $filename]} { + return -code error "File unreadable or non-existant" + } + + set f [open $filename r] + fconfigure $f -translation binary + puts "Content-Type: $contenttypes($kind)" + puts "Content-Length: [file size $filename]" + puts "Last-Modified: [lastModTime $filename]" + puts "" + fconfigure stdout -translation binary + fcopy $f stdout + flush stdout + fconfigure stdout -translation auto + close $f +} + +proc generr {title body {pfmt {}} {rcode 404} {errcode NONE}} { + global env BASETARG BASEURL CSSURL ICONURL URI DOCTYPE + + set title "ERROR: $title" + + fconfigure stdout -translation auto + + puts "Content-Type: text/html; charset=iso-8859-1" + puts "Response-Code: $rcode" + puts "" + puts $DOCTYPE + puts "$title" + puts "" + puts "" + puts "" + puts "" + puts "" + puts "" + puts "

    $title

    " + puts "

    An error occurred when serving $URI to you\ + because $body.

    " + if {[info exist env(HTTP_REFERER)]} { + puts "

    You might wish to inform the author of the\ + referring page.

    " + } + if {[string length $pfmt]} { + puts "

    Debugging Info:

    "
+	regsub -all & $pfmt {\&} pfmt
+	regsub -all < $pfmt {\<}  pfmt
+	regsub -all > $pfmt {\>}  pfmt
+	puts "$pfmt"
+	puts -nonewline "
    " + if {[string compare $errcode NONE]} { + regsub -all & $errcode {\&} errcode + regsub -all < $errcode {\<} errcode + regsub -all > $errcode {\>} errcode + puts "

    Error Code Trace:

    $errcode

    " + } + } + basicHTMLfooter + exit +} + + +proc serveFile {filename} { + global renderable DOCDIR errorInfo contenttypes + set ext [file extension $filename] + set filename [file join $DOCDIR [file tail $filename]] + if {![info exist contenttypes($ext)]} { + generr "Data unservable" \ + "that view of the document is not known and/or supported" + } + # At this point, if the working directory $DOCDIR hasn't been + # configured to get automatic updates on each commit, then a + # 'cvs update' on $filename should be done here. A 'cvs update' + # with every web hit would be very inefficient, so set up the + # automatic updates as indicated in config.tcl. + # + # If you're operating read-only, you can get away with using cron + # to run 'cvs update' instead and take whatever lag you are + # prepared to tolerate as a given... + if {[lsearch -exact $renderable $ext] >= 0} { + set filename [file rootname $filename].tip + gendoc $filename $ext + } else { + transferraw $filename $ext + } + exit +} + +proc processCGIOptions {{env env}} { # easier to test! + upvar #0 $env e + global URI SRCDIR FEATURE + global bodyURL indexType orderingColumn searchTerm searchArea + global revision0 revision1 revision2 cookie + global searchLocus searchAuthor searchDate searchDateRelation searchSort + global mailName mailUser mailSys mailTipNum + + set URI http://$e(SERVER_NAME) + if {$e(SERVER_PORT) != 80} { + append URI : $e(SERVER_PORT) + } + append URI $e(REQUEST_URI) + + if {[info exist e(HTTP_COOKIE)]} { + foreach keyval [split $e(HTTP_COOKIE) ";"] { + regexp { *([^=]+)=(.*)} $keyval -> key val + set cookie($key) $val + } + } + + switch -- $e(REQUEST_METHOD) { + GET - HEAD { + # these are OK + } + POST { + if {!$FEATURE(EDIT) && [info exist e(QUERY_STRING)]} { + switch -glob -- $e(QUERY_STRING) { + /edit/* { + generr "Unknown Request" "the request\ + $e(REQUEST_METHOD) for URL $URI is not\ + supported for that resource" {} 403 + } + } + } + source $SRCDIR/post.tcl + post::getVars $env + } + default { + generr "Unknown Request" "the request $e(REQUEST_METHOD)\ + for URL $URI is not supported for that resource" {} 403 + } + } + + array set query { + body 1.html + type * + sort none + search "" + where "" + cmpa 1.1 + cmpb 1.1 + ver NONE + locus "" + daterel "" + author "" + sortby TIP + day "" + month "" + year "" + name "" + user foobar + sys some.where + tipnum 10000 + } + array set multiple { + locus 1 + } + if {[info exist e(QUERY_STRING)]&&[string length $e(QUERY_STRING)]} { + foreach qs [split $e(QUERY_STRING) ,&] { + if { + ![regexp {^(.*)=(.*)$} $qs -> key value] || + ![info exist query($key)] + } then { + generr "Unknown URI" \ + "the uri $URI is not found on this server" + } + # Decode arguments + regsub -all {\+} $value " " value + regsub -all {[]${}\\[]} $value {\\&} value + regsub -all {%([0-9A-Fa-f][0-9A-Fa-f])} $value \ + {[format %c 0x\1]} value + if {[info exist multiple($key)]} { + lappend query($key) [subst $value] + } else { + set query($key) [subst $value] + } + } + } + + set bodyURL 1.html + set indexType * + set orderingColumn -1 + set searchTerm "" + set searchArea 0 + set revision0 NONE + set revision1 1.1 + set revision2 1.1 + + if { + ![info exist e(PATH_INFO)] || + ![string length $e(PATH_INFO)] || + [string match / $e(PATH_INFO)] + } then { + set bodyURL $query(body) + return /index.html + } + + set indexType $query(type) + set orderingColumn $query(sort) + set searchTerm $query(search) + set searchArea [string match Also* $query(where)] + set searchLocus [lsort $query(locus)] + set searchAuthor $query(author) + set searchSort $query(sortby) + if {[lsearch -exact $query(locus) created]} { + set searchDate $query(day)-$query(month)-$query(year) + set searchDateRelation $query(daterel) + } else { + set searchDate "" + set searchDateRelation "" + } + set revision0 $query(ver) + set revision1 $query(cmpa) + set revision2 $query(cmpb) + set mailName $query(name) + set mailUser $query(user) + set mailSys $query(sys) + set mailTipNum $query(tipnum) + set path $e(PATH_INFO) + if {![string length [file extension $path]]} { + append path .html + } + + return $path +} + +proc basicHTMLfooter {} { + global TCLLOGOURL TCLLOGOX TCLLOGOY FOOTERTEXT + puts "
    \"Powered
    $FOOTERTEXT
    " +} + +proc serveFrameset {body} { + global BASEURL DOCTYPE_FRAMES ICONURL + puts "Content-Type: text/html; charset=iso-8859-1" + puts "" + puts $DOCTYPE_FRAMES + puts "TIP Document Collection" + puts "" + puts "" + puts "" + puts "" + puts "" + puts "" + puts "<p align=\"justify\">Oh dear! Your browser don't seem\ + to support frames; perhaps you might wish to visit the\ + <a href=\"1.html\">TIP index</a> by way of consolation?\ + </p>" + puts "" + exit +} + +proc serveIndex {kind type} { + global BASEURL CSSURL ICONURL SRCDIR ENGINEURL DOCTYPE + puts "Content-Type: text/html; charset=iso-8859-1" + puts "" + puts $DOCTYPE + puts "TIP Index" + puts "" + puts "" + puts "" + puts "" + puts "" + puts "" + source $SRCDIR/tiphtml.tcl + tiphtml::index $kind hardError $type + puts "
    " + puts "

    The TIP archive is available by anonymous\ + CVS, and this TIP Rendering\ + engine is available online too.

    " + puts "

    \"Valid

    " + exit +} + +proc serveTclIndex {} { + puts "Content-Type: text/plain" + puts "" + set outerlist {} + foreachTIP h { + set l {} + foreach field { + TIP Type State Vote Title Created Author Version + Tcl-Version Keywords Obsoletes Obsoleted-By + Vote-By Voted-For Voted-Against Voted-Abstained + Abstract + } { + if {[info exist h($field)]} { + lappend l $field $h($field) + } + } + lappend outerlist $l + } + puts $outerlist + exit +} + +proc serveSearch {searchTerm lookInBodies} { + global BASEURL CSSURL ICONURL SRCDIR ENGINEURL DOCTYPE + source $SRCDIR/tiphtml.tcl + + puts "Content-Type: text/html; charset=iso-8859-1" + puts "" + puts $DOCTYPE + puts "Searching for\ + [tiphtml::quoteLiteral $searchTerm]" + puts "" + puts "" + puts "" + puts "" + puts "" + puts "" + if {[string length $searchTerm]} { + tiphtml::longidx * $searchTerm $lookInBodies + puts -nonewline "
    " + } + puts "
    Search for: 
     Advanced Search

    " + basicHTMLfooter + exit +} + +proc optMenu {var default args} { + set s "" +} +proc advancedSearch {} { + global BASEURL CSSURL ICONURL SRCDIR ENGINEURL DOCTYPE + source $SRCDIR/tiphtml.tcl + + puts "Content-Type: text/html; charset=iso-8859-1" + puts "" + puts $DOCTYPE + puts "Advanced Search" + puts "" + puts "" + puts "" + puts "" + puts "" + puts "" + puts "

    Advanced Search of TIP Archive

    Criteria:
    Search for in\ + Titles Keywords Abstracts Bodies
    " + puts " and by an author whose name or email address includes\ + the string:
    " + puts " and created [optMenu daterel on before after] the date\ + [optMenu day 01 02 03 04 05 06 07 08 09 10 11 12 13 14 15 16 17\ + 18 19 20 21 22 23 24 25 26 27 28 29 30 31]-[optMenu month Jan Feb\ + Mar Apr May Jun Jul Aug Sep Oct Nov Dec]-[optMenu year 2000 2001\ + 2002 2003 2004 2005]

    " + puts "

    Options:
    \ + [srchCB locus nofinal {Ignore Final TIPs}]\ + [srchCB locus nodraft {Ignore Draft TIPs}]\ + [srchCB locus project {Ignore Non-Project TIPs}]\ + [srchCB locus noreject {Ignore Rejected and Withdrawn TIPs}]

    " + puts "

    Sort result:
    Series ID Title State Type Voting Status" + basicHTMLfooter + exit +} +proc srchCB {name value label} { + regsub -all " " $label {\ } label + format " %s" \ + $name $value $label +} +proc serveSearch2 {locus pat1 pat2 date daterel order} { + global BASEURL CSSURL ICONURL SRCDIR ENGINEURL DOCTYPE + source $SRCDIR/tiphtml.tcl + + puts "Content-Type: text/html; charset=iso-8859-1" + puts "" + puts $DOCTYPE + puts "Results of Advanced Search" + puts "" + puts "" + puts "" + puts "" + puts "" + puts "" + tiphtml::longidx2 $locus $pat1 $pat2 $date $daterel $order + puts -nonewline "

    " + puts "
    Search for: 

    " + basicHTMLfooter + exit +} + +proc serveHistory {tipnumber} { + global BASEURL CSSURL ICONURL SRCDIR ENGINEURL EDITDIR DOCDIR DOCTYPE + set EDITDIR $DOCDIR + source $SRCDIR/history.tcl + + if {![regexp {^[0-9]+$} $tipnumber]} { + generr "Unknown TIP number" "TIPs must be numbered" + } + set leh [history::fmtlogentries $tipnumber] + + puts "Content-Type: text/html; charset=iso-8859-1" + puts "" + puts $DOCTYPE + puts "CVS History for TIP #$tipnumber" + puts "" + puts "" + puts "" + puts "" + puts "" + puts "" + puts "

    CVS History for TIP #$tipnumber

    " + + puts "
    $leh
    " + + basicHTMLfooter + exit +} + +proc serveDiff {tipnumber revision1 revision2} { + global BASEURL CSSURL ICONURL SRCDIR ENGINEURL EDITDIR DOCDIR DOCTYPE + set EDITDIR $DOCDIR + source $SRCDIR/history.tcl + + if {![regexp {^[0-9]+$} $tipnumber]} { + generr "Unknown TIP number" "TIPs must be numbered" + } + set dlh [history::fmtdifflines $tipnumber $revision1 $revision2] + + puts "Content-Type: text/html; charset=iso-8859-1" + puts "" + puts $DOCTYPE + puts "Comparing version $revision1 and $revision2\ + for TIP #$tipnumber" + puts "" + puts "" + puts "" + puts "" + puts "" + puts "" + puts "

    Comparing version $revision1 and $revision2 for\ + TIP #$tipnumber

    " + variable history::addbg + variable history::delbg + puts "

    Note that these changes are shown as applied to the source\ + document, and not as applied to the rendering into any\ + particular display format. Added lines are highlighted like this, and\ + deleted lines are\ + highlighted like this.

    " + + puts $dlh + + basicHTMLfooter + exit +} + +proc serveRevision {tipnumber version} { + global EDITDIR DOCDIR SRCDIR + set EDITDIR $DOCDIR + source $SRCDIR/history.tcl + + if {![regexp {^[0-9]+$} $tipnumber]} { + generr "Unknown TIP number" "TIPs must be numbered" + } + if {![regexp {^[0-9]+(\.[0-9]+)+$} $version]} { + generr "Unknown revision" "this server will not retrieve TIPs by tags" + } + set content [history::fmtrevision $tipnumber $version] + puts "Content-Type: text/html; charset=iso-8859-1" + puts "Content-Length: [string length $content]" + puts "" + puts $content + exit +} + +proc logAccess {what} { + global env LOGFILE + set RA ?.?.?.? + set UA ? + catch {set RA $env(REMOTE_ADDR)} + catch {set UA $env(HTTP_USER_AGENT)} + if {[catch {set f [open $LOGFILE a]}]} {return} + puts $f [format "%-15s\t%-10d\t%-15s\t%s" $RA [clock seconds] $what $UA] + flush $f + close $f +} + +catch { + if {[catch { + source $SRCDIR/parse.tcl + + set what [processCGIOptions] + logAccess $what + if {[info exist cookie(chongqid)]} { + generr "Temporary access problem" \ + "Temporary access problem detected; do try later." 402 + } + switch -glob -- $what { + / - /index.html { + set cmd [list serveFrameset $bodyURL] + } + /tclIndex.txt { + set cmd serveTclIndex + } + /short.html - /medium.html - /long.html { + set cmd [list serveIndex \ + [file rootname [file tail $what]] $indexType ] + } + /search.html { + set cmd [list serveSearch $searchTerm $searchArea] + } + /advancedsearch.html { + set cmd [list advancedSearch] + } + /advancedsearchresults.html { + set cmd [list serveSearch2 $searchLocus $searchTerm \ + $searchAuthor $searchDate $searchDateRelation \ + $searchSort] + } + /edit/* { + if {!$FEATURE(EDIT)} { + generr "Feature Not Supported" \ + "editing is not supported on this server" + } + source $SRCDIR/edit.tcl + set cmd [list \ + editTIP [file rootname [string range $what 6 end]] ] + } + /compare/* { + if {0&!$FEATURE(CVSWEB)} { + generr "Feature Not Supported" "CVS history inspection\ + is not supported on this server" + } + set cmd [list serveDiff \ + [file rootname [string range $what 9 end]] \ + $revision1 $revision2] + } + /history/* { + if {0&!$FEATURE(CVSWEB)} { + generr "Feature Not Supported" "CVS history inspection\ + is not supported on this server" + } + set cmd [list serveHistory \ + [file rootname [string range $what 9 end]]] + } + /view/* { + if {0&!$FEATURE(CVSWEB)} { + generr "Feature Not Supported" "CVS history inspection\ + is not supported on this server" + } + set cmd [list serveRevision \ + [file rootname [string range $what 6 end]] \ + $revision0] + } + /mail.html { + source $SRCDIR/mail.tcl + set cmd [list mail::mailform $mailName $mailUser $mailSys \ + $mailTipNum] + } + /sendmail.html { + source $SRCDIR/mail.tcl + set cmd [list mail::mailformaccept] + } + default { + set cmd [list serveFile $what] + } + } + } error]} { + generr "Internal Error" "unexpected condition \"$error\" occurred" \ + $errorInfo 500 $errorCode + } + if {[catch $cmd error]} { + generr "Internal Error" "unexpected condition \"$error\" occurred" \ + $errorInfo 500 $errorCode + } +} +exit 0 ADDED bin/tiparchive.tcl Index: bin/tiparchive.tcl ================================================================== --- /dev/null +++ bin/tiparchive.tcl @@ -0,0 +1,34 @@ +#! /usr/local/bin/tclsh8.0 + +set SRCDIR [file join [pwd] [file dirname [info script]]] +set convert {} +set pwd [pwd] +catch { + source $SRCDIR/config.tcl + source $SRCDIR/parse.tcl + source $SRCDIR/tiptex.tcl + + proc tiptex::puts {args} { + global convert + switch [llength $args] { + 2 {append convert [lindex $args 1]} + 1 {append convert [lindex $args 0] "\n"} + } + } + tiptex::generateWholeArchive + switch -- [lindex $argv 1] { + ps { + linkEPSImagesForDocument all $pwd + } + pdf { + makePDFImagesForDocument all $pwd + } + } + + set f [open [file join $pwd [lindex $argv 0]] w] + puts -nonewline $f $convert + close $f + exit +} +puts $errorInfo +exit 1 DELETED conf_def.tcl Index: conf_def.tcl ================================================================== --- conf_def.tcl +++ /dev/null @@ -1,239 +0,0 @@ -### GENERAL CONFIGURATION OF THE CONFIGURATION CODE ### - -namespace eval configure { - - # For each value that this file describes how to configure... - # - # var_name var_type default_value documentation_string - # - # The default values will be [subst]ed before assignment, and this - # operation will be applied in order to the variables. - variable variables { - DOCDIR dir {} \ - "Path to directory containing TIP archive checked out of CVS" - EDITDIR dir {} "Path to directory to use for web editing" - BASETARG string _self "Name of target window for links in HTML" - BASEURL string {} \ - "URL which CGI script will operate as, with trailing '/'" - CSSURL string http://www.cs.man.ac.uk/~fellowsd/std.css \ - "URL for style sheet to apply to HTML" - ICONURL string http://www.tcl.tk/favicon.ico \ - "URL for link icon to apply to all HTML documents" - ENGINEURL string http://sourceforge.net/projects/tiprender/ \ - "URL for TIP Renderer project on SourceForge" - TCLLOGOURL string http://tcl.sourceforge.net/images/tclp.gif \ - "URL of Tcl logo image" - TCLLOGOX number 42 "Horizontal size of Tcl logo image" - TCLLOGOY number 64 "Vertical size of Tcl logo image" - TCLCOREMAIL string tcl-core@lists.sourceforge.net \ - "General email address for correspondence w.r.t. TIP contents" - FOOTERTEXT string "TIP AutoGenerator - written by Donal K. Fellows" \ - "Text footer of formatted pages; not HTML, must be HTML-safe" - LOGFILE file {} \ - "Path to log file (must be writable by CGI script)" - CVS_CLIENT file {[locateBinary cvs /usr/bin/cvs]} \ - "Path to cvs client binary" - SENDMAIL file {[locateBinary sendmail /usr/lib/sendmail]} \ - "Path to sendmail (or compatible) binary" - GS file {[locateBinary gs /usr/bin/gs]} \ - "Path to ghostscript binary" - PDFLATEX file {[locateBinary pdflatex /usr/bin/pdflatex]} \ - "Path to PDFLaTeX binary" - PUBLISHURL string http://purl.org/tcl/tip \ - "Base URL for publishing" - EDITURLBASE string http://purl.org/tcl/tip/edit \ - "Base URL for web editing" - CVSWEBURL string {[set BASEURL]history/%d} \ - "URL for cvsweb access; passed through format" - SENDMAILURL string {[set BASEURL]sendmail.html} \ - "URL for web-to-mail form to target" - TESTINGTIP number 10000 "Number of TIP used for testing" - ISSUEBASE string {https://sourceforge.net/support/tracker.php?aid=}\ - "(Partial) URL for where to look up bugs/patches" - - FEATURE(EDIT) boolean 0 "Support web editing" - COOKIEPATH string {[pathComponent $BASEURL /]} \ - "Path control value for cookies generated, with trailing '/'" - FEATURE(CVSWEB) boolean 1 "Support history inspection" - FEATURE(EDIT_URL_IN_NEWS_MESSAGE) boolean 1 \ - "Put edit URL in published news msgs" - FEATURE(EDIT_URL_HTML) boolean 1 "Put edit URL in HTML page" - FEATURE(PUBLISHING) boolean 0 \ - "Can publish announcements of new TIPs" - - history::infobg colour #80ff80 "Colour of log entries" - history::logbg colour #b0d0ff "Colour of history details" - history::addbg colour #80ff80 "Colour of added lines" - history::delbg colour #ffa0a0 "Colour of deleted lines" - } - - - # Which values are optional (configurable only if the -expert option is - # passed to makeconfig.tcl) as the defaults are typically good enough. - variable optional { - BASETARG CSSURL ICONURL ENGINEURL TCLLOGOURL TCLLOGOX TCLLOGOY - FOOTERTEXT ISSUEBASE - PUBLISHURL EDITURLBASE CVSWEBURL TESTINGTIP COOKIEPATH TCLCOREMAIL - FEATURE(EDIT) FEATURE(EDIT_URL_IN_NEWS_MESSAGE) FEATURE(PUBLISHING) - history::logbg history::infobg history::addbg history::delbg - SENDMAILURL - } - - - # Organize the values into pages (using a list of lists). The first - # element of each sublist is the title of the page/window, and the other - # elements are the variables to configure on that page. Note that the - # first page should usually be written pretty much as-is and the empty - # "variable" is actually not a variable at all but rather a way of putting - # a message up (its kind is always message) with the content of the - # message taken from the introMessage variable (below.) - # - # If the first variable on a page is optional, the whole page is optional. - variable pages { - { - "Configuring TIP Renderer" - "" - } - { - "Basic Locations" - DOCDIR EDITDIR BASEURL TCLCOREMAIL - } - { - "Self Advertising" - BASETARG CSSURL ICONURL ENGINEURL FOOTERTEXT TESTINGTIP - } - { - "Tcl Powered Logo" - TCLLOGOURL TCLLOGOX TCLLOGOY - } - { - "Editing Features" - EDITURLBASE CVSWEBURL FEATURE(EDIT) COOKIEPATH - } - { - "Publishing Features" - FEATURE(PUBLISHING) PUBLISHURL FEATURE(EDIT_URL_IN_NEWS_MESSAGE) - } - { - "Advanced Reporting" - FEATURE(CVSWEB) FEATURE(EDIT_URL_HTML) - } - { - "CVS-Web Colours" - history::infobg history::logbg history::addbg history::delbg - } - { - "Mail Control" - SENDMAILURL TCLCOREEMAIL - } - { - "Executables and Logs" - CVS_CLIENT SENDMAIL GS PDFLATEX LOGFILE - } - } - - - # Introductory message for the first page that the user sees. Should - # mention the -expert option and any other options that you define. - variable introMessage "Welcome to the TIP Rendering engine configuration\ - wizard. Please supply a value for all empty fields and check\ - that all other fields are set to sensible values. Many more\ - fields are available to edit if you start this script with the\ - -expert option. Once you have chosen values for everything,\ - this script will write a suitable config.tcl for you into the\ - current directory." - - - # String to write at the front of the configuration file. Contains bits - # that are needed always (typically things that are only ever configured - # by the code author). Leading whitespace from each line will be - # stripped... - variable header { - # Both $DOCDIR and $EDITDIR should be working directories checked out - # from the same CVS repository if web-editing is enabled. The CGI - # process needs write access to $EDITDIR, and commit privileges to - # CVS. $DOCDIR must be configured to receive updates each time a - # change is committed. - # (See Appendix C, Section C.7.2 of the CVS manual). - - set URI ??? - namespace eval ::history {} - - array set contenttypes { - .tip "text/x-tcl-tip; charset=iso-8859-1" - .html "text/html; charset=iso-8859-1" - .htm "text/html; charset=iso-8859-1" - .txt "text/plain; charset=iso-8859-1" - .patch "text/plain; charset=iso-8859-1" - .tex "application/x-latex; charset=iso-8859-1" - .xml "text/xml; charset=iso-8859-1" - .gif "image/gif" - .jpg "image/jpeg" - .jpeg "image/jpeg" - .jpe "image/jpeg" - .png "image/png" - .ppm "image/x-portable-pixmap" - .ps "application/postscript" - .eps "application/postscript" - .fig "application/x-fig" - .tcl "application/x-tcl; charset=iso-8859-1" - .dtd "application/xml-dtd; charset=iso-8859-1" - .xml "text/xml; charset=iso-8859-1" - .ms "application/x-troff; charset=iso-8859-1" - .rtf "text/rtf; charset=iso-8859-1" - } - - set renderable {} - set renderexts {} - foreach ext [array names contenttypes] { - if {[file exists $SRCDIR/tip[string trim $ext .].tcl]} { - lappend renderable $ext - lappend renderexts [string trim $ext .] - } - } - } - - catch { - if {[string match *Name:*.cs.man.ac.uk* \ - [exec nslookup [info hostname]]]} { - append header { - ### UGLY HACK ALERT! Fix access to suitable .cvspass file ### - set ::env(HOME) $SRCDIR/cvshack - if {[catch {exec $SRCDIR/cvshack/fix} msg]} { - puts "Content-Type: text/plain\n\nERROR: $msg" - exit - } - } - } - } -} - -### CODE THAT IS NEEDED FOR THIS PARTICULAR CONFIGURATION ### - -# Procedure to derive proper command paths from the name of the command and -# the current path (UNIX-specific.) -proc locateBinary {name fallback} { - global env - set pwd [pwd] - foreach dir [split $env(PATH) ":"] { - set fn [file join $pwd $dir $name] - if {[file isfile $fn] && [file executable $fn]} { - return $fn - } - } - return $fallback -} - -# Procedure to extract the path part of a URL. -proc pathComponent {url fallback} { - if {[regexp {^[^/]+//[^/]+(/.*)$} $url -> path]} { - return $path - } - return $fallback -} - -# Hack to make sure that setting variables directly into namespaces works... -namespace eval ::history {} - -# I like greys, and this undoes all sorts of CDE nastiness... -tk_setPalette grey85 DELETED config.tcl Index: config.tcl ================================================================== --- config.tcl +++ /dev/null @@ -1,110 +0,0 @@ -# Points into local copy of CVS archive -set DOCDIR /home/fellowsd/lang/tcl/tip - -# Both $DOCDIR and $EDITDIR should be working directories checked out -# from the same CVS repository. The CGI process needs write access -# to $EDITDIR, and commit privileges to CVS. $DOCDIR must be -# configured to receive updates each time a change is committed. -# (See Appendix C, Section C.7.2 of the CVS manual). -##set DOCDIR $SRCDIR/tips -set EDITDIR $SRCDIR/tipedit - -set BASETARG _self -set BASEURL http://www.cs.man.ac.uk/fellowsd-bin/TIP/ -set CSSURL http://www.cs.man.ac.uk/~fellowsd/std.css -set ICONURL http://www.tcl.tk/favicon.ico -set ENGINEURL http://sourceforge.net/projects/tiprender/ -set TCLLOGOURL http://tcl.sourceforge.net/images/tclp.gif -# Size of image at above URL -set TCLLOGOX 42 -set TCLLOGOY 64 -set FOOTERTEXT "TIP AutoGenerator - written by Donal K. Fellows" -set URI ??? -set LOGFILE /home/fellowsd/lang/tcl/TIP/log -### More complex because I want to run on several platforms at once! -switch $tcl_platform(os) { - SunOS { - set CVS_CLIENT /home/fellowsd/arch/sparc-sun-solaris/bin/cvs - set SENDMAIL /usr/lib/sendmail - set GS /opt/cs/bin/gs - set PDFLATEX /opt/cs/bin/pdflatex - } - Linux { - set CVS_CLIENT /usr/bin/cvs - set SENDMAIL /usr/sbin/sendmail - set GS /usr/bin/gs - set PDFLATEX /usr/bin/pdflatex - } -} -# Separate, since might be a PURL -set PUBLISHURL http://purl.org/tcl/tip -# Separate, since might not reside on same server. -set EDITURLBASE http://purl.org/tcl/tip/edit -set CVSWEBURL ${BASEURL}history/%d -set TESTINGTIP 10000 -set COOKIEPATH /fellowsd-bin/TIP/ -set TCLCOREMAIL tcl-core@lists.sourceforge.net -set SENDMAILURL http://www.cs.man.ac.uk/fellowsd-bin/TIP/sendmail.html -set ISSUEBASE https://sourceforge.net/support/tracker.php?aid= - -array set FEATURE { - EDIT 0 - CVSWEB 1 - EDIT_URL_IN_NEWS_MESSAGE 1 - EDIT_URL_HTML 1 - PUBLISHING 1 -} - -### UGLY HACK ALERT! Gives access to suitable .cvspass file ### -set ::env(HOME) $SRCDIR/cvshack -set msg {} -foreach exe [list fix_$tcl_platform(machine)_$tcl_platform(os) fix] { - if {![catch {exec $SRCDIR/cvshack/$exe} msg]} { - break - } -} -if {[string length $msg]} { - puts "Content-Type: text/plain\n\nERROR: $msg" - exit -} - -namespace eval history { - # Assorted configurable parameters for the history management mechanism. - variable cmpurl compare - variable logbg #b0d0ff - variable infobg #80ff80 - variable addbg #80ff80 - variable delbg #ffa0a0 -} -array set contenttypes { - .tip "text/x-tcl-tip; charset=iso-8859-1" - .html "text/html; charset=iso-8859-1" - .htm "text/html; charset=iso-8859-1" - .txt "text/plain; charset=iso-8859-1" - .patch "text/plain; charset=iso-8859-1" - .tex "application/x-latex; charset=iso-8859-1" - .xml "text/xml; charset=iso-8859-1" - .gif "image/gif" - .jpg "image/jpeg" - .jpeg "image/jpeg" - .jpe "image/jpeg" - .png "image/png" - .ppm "image/x-portable-pixmap" - .ps "application/postscript" - .eps "application/postscript" - .fig "application/x-fig" - .tcl "application/x-tcl; charset=iso-8859-1" - .dtd "application/xml-dtd; charset=iso-8859-1" - .xml "text/xml; charset=iso-8859-1" - .ms "application/x-troff; charset=iso-8859-1" - .rtf "text/rtf; charset=iso-8859-1" -} - -set renderable {} -set renderexts {} -foreach ext [array names contenttypes] { - if {[file exists $SRCDIR/tip[string trim $ext .].tcl]} { - lappend renderable $ext - lappend renderexts [string trim $ext .] - } -} DELETED cvs.tcl Index: cvs.tcl ================================================================== --- cvs.tcl +++ /dev/null @@ -1,83 +0,0 @@ -# FILE: cvs.tcl -# -# Routines that interface to the CVS client program and manage file locks - -proc acquireLock {tip} { - global EDITDIR - - # Write our lock file -- overwrite any left by prior owners of our pid - set lockFile [file join $EDITDIR .$tip.lock] - set myLockFile [file join $EDITDIR .$tip.[pid].lock] - set myReleaseFile [file join $EDITDIR .$tip.[pid].release] - file delete -- $myReleaseFile - set f [open $myLockFile w] - puts $f $myReleaseFile - close $f - - set tries 30 - while {[incr tries -1]} { - # Try to claim the lock by renaming our lock file to the lock - # file for the TIP we want to lock. Only one process can win - # this race. - if {![catch {file rename -- $myLockFile $lockFile}]} { - - # Here we might try setting up child process to release - # the lock in case we are killed before we release it. - # (CGI spec allows the CGI script to be killed at any time.) - - # We got the lock! acquireLock can return - return - } - - # Someone else holds the lock. Read it. - set f [open $lockFile] - set releaseFile [gets $f] - close $f - # How old is it? - if {![catch {file mtime $lockFile} lockTime] - && ([clock seconds] - $lockTime) > 120} { - # The lock is more than 5 minutes old. Assume that - # the process that acquired the lock died without - # releasing it. We'll release it instead. - # - # Release the lock file by renaming it so that only - # one process can succeed in releasing it. - catch {file rename -- $lockFile $releaseFile} - } - - # Wait a couple seconds, then try again to acquire the lock. - after 2000 - } - - # After several tries, we never acquired the lock - file delete -- $myLockFile - return -code error "could not acquire lock" -} - -proc releaseLock {tip} { - global EDITDIR - set lockFile [file join $EDITDIR .$tip.lock] - - # If a child process was launched as a safeguard to release - # our lock, cancel it. - - # Release my lock. - file delete -- $lockFile -} - -proc cvs {args} { - global EDITDIR CVS_CLIENT errorCode - - if {[catch { - cd $EDITDIR - uplevel 1 [linsert $args 0 exec $CVS_CLIENT -q] - } result]} { - # CVS writes lots of messages to stderr. Don't treat those - # messages as errors. Only raise an error on a non-zero exit - # status. - if {[string match CHILDSTATUS [lindex $errorCode 0]]} { - return -code error "$result (exit code was [lindex $errorCode 2])" - } - } - return $result -} DELETED cvsupdate.tcl Index: cvsupdate.tcl ================================================================== --- cvsupdate.tcl +++ /dev/null @@ -1,13 +0,0 @@ -#! /bin/sh - -# Brings local copy of CVS archive up-to-date. \ -exec /home/fellowsd/arch/sparc-sun-solaris/bin/tclsh8.0 "$0" -- ${1+"$@"} - -set SRCDIR [file join [pwd] [file dirname [info script]]] -source $SRCDIR/config.tcl -set EDITDIR $DOCDIR -source $SRCDIR/cvs.tcl - -set code [catch {cvs -z9 update} msg] -if {[string length [string trim $msg]]} {puts $msg} -exit $code DELETED edit.tcl Index: edit.tcl ================================================================== --- edit.tcl +++ /dev/null @@ -1,386 +0,0 @@ -# FILE: edit.tcl -# -# Routines to manage the editing of a TIP via the web. - -proc setPOSTdefaults {array} { - global SRCDIR - upvar 1 $array h - - # When is the TIP available for editing through the web? - # If the State is Draft, and the vote is still pending. - # Might adjust these conditions to taste... - if {[notEditable? h]} { - refuseToEdit h - } - if {![info exists ::post::operation]} { - source $SRCDIR/post.tcl - } - - if {![info exists ::post::revision]} { - regexp {^\$([^:]+): (.*)\$$} $h(Version) -> keyword expansion - switch [string tolower $keyword] { - id { - regexp {tip,v ([0-9.]+)} $expansion -> ::post::revision - } - revision { - set ::post::revision [string trim $expansion] - } - default { - return -code error "Header field Version: must be\ - a CVS keyword expansion of Revision: or Id:" - } - } - } - - if {![info exists ::post::abstract]} { - set ::post::abstract $h(RawAbstract) - } - if {![info exists ::post::body]} { - set ::post::body [join $h(Body) \n\n] - } - if {![info exists ::post::log]} { - set ::post::log {} - } -} - -proc cookieHeader {key value} { - global EDITURLBASE COOKIEPATH - binary scan $value H* hexvalue - return "Set-Cookie: $key=$hexvalue; path=$COOKIEPATH;\ - expires=Sunday, 01-Jan-2034 00:00:00 GMT" - # Expires line is extracted from Netscrape cookie documentation... -} -proc getCookie {key} { - global cookie - set value {} - catch { - # Fails if malformatted or non-existant, but that's OK - set value [binary format H* $cookie($key)] - } - return $value -} - -proc editTIP {id} { - global DOCDIR URI - - set filename [file join $DOCDIR $id.tip] - if {![file readable $filename]} { - generr "Not Found" "that document is not available on this server." - } - - array set details [getTIPDetails $filename] - setPOSTdefaults details - switch -exact -- $::post::operation { - edit { - if {![string length $::post::email]} { - set ::post::email [getCookie tipwebEMAIL] - } - if {![string length $::post::name]} { - set ::post::name [getCookie tipwebNAME] - } - presentForm details - } - commit { - attemptCommit details - } - default { - generr "Invalid Request" "the request POST for URL $URI provided\ - invalid value '$::post::operation' for form variable\ - 'operation'." {} 403 - } - } -} - -proc refuseToEdit {array} { - global BASEURL CSSURL ICONURL FOOTERTEXT - upvar 1 $array h - - puts "Content-Type: text/html; charset=iso-8859-1" - puts "" - puts "" - puts "TIP #$h(TIP): Editing Refused" - puts "" - puts "" - puts "" - puts "" - puts "" - puts "" - puts "

    TIP #$h(TIP): $h(Title)

    " - - puts -nonewline "

    TIP #$h(TIP) may not be edited\ - through the web because " - if {[string match "In progress" $h(Vote)]} { - puts "a vote is in progress.

    " - } else { - puts "its State is $h(State).

    " - } - puts "

    View the current revision of \ - TIP #$h(TIP).

    " - puts "
    $FOOTERTEXT
    " - exit -} - -proc presentForm {array {msg ""}} { - global SRCDIR BASEURL FOOTERTEXT ENGINEURL - upvar 1 $array h - variable ::post::abstract - variable ::post::revision - variable ::post::body - variable ::post::email - variable ::post::name - variable ::post::log - - puts "Content-Type: text/html; charset=iso-8859-1\n" - source $SRCDIR/tiphtml.tcl - tiphtml::generateTIPHeader [array get h] - if {[string length $msg]} { - puts "

    $msg" - } - puts "

    Please enter your e-mail address (required),\ - your name (optional), make your edits to this TIP and its\ - Abstract, and Submit them. See TIP 3 for a description of the TIP\ - format.

    " - puts "

    You are advised to copy the text of\ - the TIP into an editor, make your edits there, and then paste\ - back.

    " - puts "
    " - puts "Name:
    E-mail:" - puts "" - puts "
    " - puts "" - puts "

    Abstract:" - puts "

    This is a supplement to the\ - main log message to allow you to add extra notes if you\ - wish.

    " - puts "
    " - puts "" - puts "
    Body:" - puts "" - puts "
    Log:

    Note that\ - when you submit this form, the server will attempt to store\ - your personal details (i.e. name and email address) as\ - cookies in your browser so that next time you edit a TIP, you\ - do not need to retype this info. We do not retain the information\ - on our server (other than as logged in the TIP itself and in\ - the CVS log) and you can delete it without ill-effect if you\ - wish. You are invited to study the\ - implementation code if you wish to understand exactly how\ - the information is stored in your browser.

    $FOOTERTEXT
    " - exit -} - -proc attemptCommit {array} { - global EmailRE EDITDIR BASEURL SRCDIR DOCDIR - upvar 1 $array h - - if {![regexp $EmailRE <$::post::email>]} { - presentForm h "You must provide a valid e-mail address!" - } - - set pars [splitIntoParagraphs [string trim $::post::body]] - - # Force Abstract into a single paragraph and heading and stick - # it at the beginning. - set pars [linsert $pars 0 "~ Abstract" [join [splitIntoParagraphs \ - [string trim $::post::abstract]] \n]] - - # Double-check we did that right... - if {[string compare {section Abstract 1} \ - [intuitParagraphKind [lindex $pars 0]]]} { - presentForm h "Each TIP must begin with an Abstract!" - } - - # For wiki-spam, we adopt an evil approach; we pretend that we've - # successfully checked in the change but in fact we've done - # nothing of the sort and just format the page that the user - # submitted so that it appears they were successful. - if {[isWikispam h $pars]} { - global COOKIEPATH - array set oldHeaders [getTIPDetails $DOCDIR/$h(TIP).tip] - set oldHeaders(Post-History) \ - "Wikispam detected: $why\ - Contact the\ - TIP Editor for help, including the change this TIP." - set ohpar [constructTIPHeader [array get oldHeaders]] - set data [formatTIPDocument $ohpar\n\n[join $pars \n\n]] - puts "Content-Type: text/html" - puts "Content-Length: [string length $data]" - puts [cookieHeader chongqid $::post::name] - puts "" - puts -nonewline $data - exit - } - - # Remove any CVS keyword expansion from the new TIP body to avoid - # conflict false alarms. - # - # At this point we could do any additional consistency or format - # checking on the new TIP body, and return bad TIPs to submitter - # for more editing. - # - set newBody [join $pars \n\n] - foreach keyword [list Author Date Header Id Name Locker Log RCSfile \ - Revision Source State] { - regsub -all -- \\$$keyword:?.*\\$ $newBody $$keyword$ newBody - } - - # Change to the working directory for editing, so cvs commands - # will work, and filenames can be relative. - cd $EDITDIR - - # OK, now comes the tricky part. We need exclusive access to the - # .tip file in $EDITDIR so we can update, merge, and commit the new - # changes in the TIP without interference from other CGI processes - # trying to do the same thing. So, we use a locking mechanism. - # See cvs.tcl for details. - source $SRCDIR/cvs.tcl - - # The next command will block until it can aquire the lock it needs. - if {[catch {acquireLock $h(TIP)}]} { - presentForm h "Could not acquire a lock on a working copy of\ - $h(TIP).tip. Please wait a moment and try your\ - submission again." - } - - # Retrieve from CVS the revision on which the new edits are based. - set file $h(TIP).tip - file delete -- $file - cvs update -r $::post::revision -kk $file - - # Replace the old body with the new body. Keep the old headers so we - # avoid any merging conflicts in the headers. -# set newTIP [constructTIPHeader [getTIPDetails $file]]\n\n[join $pars \n\n] - set newTIP [constructTIPHeader [getTIPDetails $file]]\n\n$newBody - file delete -- $file - set f [open $file w] - puts $f $newTIP - close $f - - # Merge in the other changes from the HEAD revision. Record whether - # there was a conflict, and read in the merged result. - set conflict [string match "*C $file*" [cvs update -A -kk $file]] - array set details [array get h] - array set details [getTIPDetails $file] - - # Add submitter as a new Author in headers, if necessary - set newAuthor 1 - foreach author $details(Author) { - if {[string match *<$::post::email>* $author]} { - set newAuthor 0 - break - } - } - if $newAuthor { - lappend details(Author) "$::post::name <$::post::email>" - set newTIP [constructTIPHeader [array get details]] - append newTIP "\n\n~ Abstract\n\n$details(RawAbstract)" - append newTIP \n\n[join $details(Body) \n\n] - file delete -- $file - set f [open $file w] - puts $f $newTIP - close $f - } - - if {$conflict} { - regexp {revision:[ \t]*([0-9.]+)} [cvs status $file] -> ::post::revision - - # After releasing the lock, send a form back to - # submitter to resolve the conflict. - set postReleaseScript { - unset ::post::abstract - unset ::post::body - setPOSTdefaults details - presentForm details "Your changes conflicted with changes from\ - someone else. Please resolve the conflict and submit\ - again." - } - - } else { - # No conflict. Try to commit the new revision to CVS - - set msg "Revision through web from $::post::name <$::post::email>" - if {[info exists ::post::log] && [string length $::post::log]} { - append msg "\n" [string trim $::post::log] - } - - if {[catch {cvs commit -m $msg $file} msg]} { - - # A failed 'cvs commit' after a successful 'cvs update' probably - # means another 'cvs commit' occurred (from somewhere other than - # the web interface) since our 'cvs update'. Try again. - set postReleaseScript { - attemptCommit h - } - - } else { - # Successful commit. - # Give it a second to push through, then redirect to the HTML - # rendering of the new revision. - set postReleaseScript { - after 2100 - puts "Location: $BASEURL$details(TIP).html" - puts [cookieHeader tipwebEMAIL $::post::email] - puts [cookieHeader tipwebNAME $::post::name] - puts "" - } - } - } - - releaseLock $h(TIP) - eval $postReleaseScript -} - -proc isWikispam {headerArray paragraphs {whyVar why}} { - upvar 1 $headerArray h $whyVar why - global DOCDIR - - # Spammers are lazy, real contributors are (usually) not. - - if {[llength [split $::post::name]] < 2} { - set why "short real name" - return 1 - } - - # Count the number of http urls in the original and the new - # version. Note that these searches are *very* simple-minded, but - # that should be enough. - - set old [getTIPFileContents [file join $DOCDIR $h(TIP).tip]] - set oldCount 0 - set idx 0 - while {[set idx [string first http: $old $idx]] >= 0} { - incr oldCount - incr idx - } - - set new [join $paragraphs] - set newCount 0 - set idx 0 - while {[set idx [string first http: $new $idx]] >= 0} { - incr newCount - incr idx - } - - # It's spam if more than two things that look vaguely like http - # URIs are added in a single update - if {$newCount > $oldCount + 2} { - set why "too many added URLs" - return 1 - } - return 0 -} DELETED epstopdf.tcl Index: epstopdf.tcl ================================================================== --- epstopdf.tcl +++ /dev/null @@ -1,128 +0,0 @@ -# Procedure to convert Encapsulated Postscript into PDF by passing -# through ghostscript with the right arguments and with the bounding -# box fixed(!) Based very strongly on the EPSTOPDF script distributed -# with teTeX-1.0 though with some changes (most notably support for -# controlling the level of PDF generated, and redesigned for more -# efficient use as part of a larger work.) - -# This version by Donal K. Fellows, University of Manchester - -# Original by Sebastian Rahtz et al. - -namespace eval epstopdf { - proc correctBbox {llx lly urx ury} { - variable corrected 1 - set width [expr {$urx-$llx}] - set height [expr {$ury-$lly}] - format "%%BoundingBox: 0 0 %d %d\n<< /PageSize \[%s %s\] >>\ - setpagedevice gsave %s %s translate" \ - $width $height $width $height [expr {-$llx}] [expr {-$lly}] - } - proc processHeader {bbstring} { - variable in - variable out - variable isfile - - set spc "\[ \t\]" - set elm {([-0-9e.]+)} - set bboxRE "^%%${bbstring}:$spc*$elm$spc+$elm$spc+$elm$spc+$elm" - set atendRE "^%%${bbstring}:$spc*\\(atend\\)" - while {[gets $in line] >= 0} { - ### end of header - if { - ![string match %* $line] || - [string match %%EndComments* $line] - } then { - puts $out $line - break - } - - ### BoundingBox with values - if {[regexp $bboxRE $line -> llx lly urx ury]} { - puts $out [correctBbox $llx $lly $urx $ury] - break - } - - ### BoundingBox with (atend) - # Can only be processed if seek/tell work (i.e. is ordinary file) - if {[regexp $atendRE $line] && $isfile} { - set pos [tell $in] - # looking for %%BoundingBox - while {[gets $in line] >= 0} { - # skip over included documents - if {[string match %%BeginDocument* $line]} { - while {[gets $in line] >= 0} { - if {[string match %%EndDocument* $line]} {break} - } - } - if {[regexp $bboxRE $line -> llx lly urx ury]} { - puts $out [correctBbox $llx $lly $urx $ury] - break - } - } - - # go back - seek $in $pos - break - } - - # print header line - puts $out $line - } - } - - variable options - array set options { - UseFlateCompression true - CompatibilityLevel 1.2 - } - if {![info exist ::GS]} { - set ::GS gs - } - - namespace export epstopdf - proc epstopdf {infile {outfile ""} {bbstring "BoundingBox"}} { - variable options - variable in - variable out - variable corrected 0 - variable isfile - global GS - - if {![string length $outfile]} { - if {[string compare [file extension $infile] .eps]} { - return -code error "cannot guess output filename" - } - set outfile [file rootname $infile].pdf - } - - set cmd [list $GS -q -sDEVICE=pdfwrite -sOutputFile=$outfile] - foreach key [array names options] { - lappend cmd -d$key=$options($key) - } - lappend cmd - -c quit - - set isfile [file isfile $infile] - set in [open $infile r] - fconfigure $in -translation binary - set out [open |$cmd w] - fconfigure $out -translation binary - - gets $in line - # Trim leading junk which some EPS generators insist on adding - set line [string range $line [string first %! $line] end] - puts $out $line - - if {[string match %* $line]} { - processHeader $bbstring - } - fcopy $in $out - close $in - if {$corrected} { - puts $out grestore - } else { - puts stderr "warning: $bbstring not found in $infile" - } - close $out - } -} DELETED history.tcl Index: history.tcl ================================================================== --- history.tcl +++ /dev/null @@ -1,192 +0,0 @@ -source $SRCDIR/cvs.tcl - -proc history::logentries {file} { - set entries {} - set gotfirst 0 - set pattern1 ---------------------------- - set pattern0 ============================================================================= - foreach line [split [string trim [cvs log -N $file]] "\n"] { - if {[string match $pattern0 $line]} { - lappend entries $accum - break - } - if {[string match $pattern1 $line]} { - if {$gotfirst} { - lappend entries $accum - } else { - set gotfirst 1 - } - set accum {} - continue - } - lappend accum $line - } - set revisions {} - array set info {} - foreach entry $entries { - regexp {revision (.*)} [lindex $entry 0] -> revision - lappend revisions $revision - foreach kv [split [lindex $entry 1] ";"] { - set kv [string trim $kv] - if {![string length $kv]} {continue} - regexp {([^:]+): +(.*)} $kv -> key value - set info($revision,$key) $value - } - # Trim off unwanted lines - set log [lrange $entry 2 end] - while {[string match {branches: *;} [lindex $log 0]]} { - set log [lrange $log 1 end] - } - set info($revision,logmsg) [join $log "\n"] - } - return [list $revisions [array get info]] -} - -proc history::difflines {file r1 r2} { - set lines {} - set inheader 1 - set seppat @@*@@ - catch {cvs diff -u -b -r$r1 -r$r2 $file} msg - foreach line [split [string trim $msg] \n] { - if {[string match $seppat $line]} { - if {!$inheader} { - lappend lines sep - } else { - set inheader 0 - } - } elseif {!$inheader} { - regexp {(.)(.*)} $line -> type content - while {[regexp -indices "\t" $content tabpos]} { - set tabpos [lindex $tabpos 0] - set pre [string range $content 0 [expr {$tabpos-1}]] - set post [string range $content [expr {$tabpos+1}] end] - ### [string repeat] is not available in 8.0 - append pre " " - while {[string length $pre]%8} {append pre " "} - set content $pre$post - } - switch -- $type { - - {lappend lines [list del $content]} - + {lappend lines [list add $content]} - " " {lappend lines [list ctx $content]} - } - } - } - return $lines -} - -proc history::quoteEnt {string} { - regsub -all & $string {\&} string - regsub -all \" $string {\"} string - regsub -all < $string {\<} string - regsub -all > $string {\>} string - return $string -} -proc history::quoteEmail1 {string} { - global EmailRE - regsub -all $EmailRE $string "<\x80\\1\x81>" string - return $string -} -proc history::quoteEmail2 {string tip} { - while {[regexp -indices "\x80\[^\x80\x81\]+\x81" $string locn]} { - foreach {first last} $locn {} - set mail [string range $string [expr {$first+1}] [expr {$last-1}]] - foreach {user sys} [split $mail @] {break} - regsub -all {\.} $user " dot " user - regsub -all {\.} $sys " dot " sys - set newstring [string range $string 0 [expr {$first-1}]] - append newstring "$user at $sys" - set string $newstring[string range $string [expr {$last+1}] end] - } - return $string -} - -proc history::fmtlogentries {tipid} { - set loginfo [logentries $tipid.tip] - array set info [lindex $loginfo 1] - - variable infobg - variable logbg - - append puts "AuthorQuick Comparison\n" - set vs [lsort -dictionary [lindex $loginfo 0]] - foreach v $vs { - # hardcoded value! - if {![string compare $info($v,author) "tclhttpd"]} { - set info($v,author) "WebEdit" - } - append puts "$info($v,author)$info($v,date)\n" - append puts "\n" - append puts "\n" - append puts "\n" - } - append puts "" - append puts "
    VersionDate
    $vView this version
    Log Message
    \n"
-	set loglines [quoteEmail1 $info($v,logmsg)]
-	set loglines [join [split [quoteEnt $loglines] "\n"] "\n  "]
-	set loglines [quoteEmail2 $loglines $tipid]
-	append puts "  $loglines
    \n" - append puts "\n" - append puts "
    " -} - -proc history::fmtdifflines {tipid r1 r2} { - variable addbg - variable delbg - - set old {} - set lineinfo [difflines $tipid.tip $r1 $r2] - set maxl 0 - - if {![llength $lineinfo]} { - return "

    No differences or at least one version non-existent.

    " - } - - foreach line $lineinfo { - set len [string length [lindex $line 1]] - if {$len>$maxl} {set maxl $len} - } - append puts "
    \n"
-    foreach line $lineinfo {
-	set c [quoteEnt [format %-*s $maxl [lindex $line 1]]]
-	append puts $old
-	set old {}
-	switch [lindex $line 0] {
-	    sep {append puts "
    "}
-	    ctx {append puts "$c\n"}
-	    add {
-		append puts "$c\n"
-		set old ""
-	    }
-	    del {
-		append puts "$c\n"
-		set old ""
-	    }
-	    default {append puts ==$line==\n}
-	}
-    }
-    append puts "
    " -} - -proc history::fmtrevision {tipid revision} { - set document [cvs update -pr $revision $tipid.tip 2>/dev/null] - formatTIPDocument $document html $revision -} DELETED imwidth.tcl Index: imwidth.tcl ================================================================== --- imwidth.tcl +++ /dev/null @@ -1,198 +0,0 @@ -namespace eval ::imwidth { - namespace export getImageWidth - - variable imageWidthCache - array set imageWidthCache {} - proc getImageWidth {imagefile} { - variable imageWidthCache - if {![info exist imageWidthCache($imagefile)]} { - set imageWidthCache($imagefile) 0 - if {[catch { - set imageWidthCache($imagefile) [getImageWidthCore $imagefile] - } msg]} { - puts "DEBUG: imwidth $imagefile -> $msg" - puts ErrorCode=$::errorCode - puts ErrorInfo=$::errorInfo - } - } - return $imageWidthCache($imagefile) - } - proc getImageWidthCore {imagefile} { - global contenttypes - set ext [file extension $imagefile] - if {![string compare $contenttypes($ext) application/postscript]} { - return [epswidth $imagefile] - } - if {![regexp {image/([-a-z]+)} $contenttypes($ext) -> type]} { - return 0 - } - switch $type { - gif { - return [gifsize $imagefile] - } - jpeg { - return [get_jpg_width $imagefile] - } - png { - return [pngsize $imagefile] - } - x-portable-pixmap { - return [PPMwidth $imagefile] - } - } - return 0 - } - - proc PPMwidth {filename} { - set f [open $imagefile r] - gets $f;# Read magic number - while {[gets $f s]+1&&[string length $s]&&[string match #* $s]} {} - close $f - scan $s %d width - return $width - } - - # From the Wiki! - proc gifsize {name} { - set f [open $name r] - fconfigure $f -translation binary - # read GIF signature -- check that this is - # either GIF87a or GIF89a - set sig [read $f 6] - switch $sig { - "GIF87a" - - "GIF89a" { - # do nothing - } - default { - error "$f is not a GIF file" - } - } - - # Read "logical screen size", this is USUALLY the image size - # too. Interpreting the rest of the GIF specification is left - # as an exercise - binary scan [read $f 2] s wid - - return $wid - } - - # From the Wiki! - proc get_jpg_width {filename} { - # open the file - set img [open $filename r+] - # set to binary mode - VERY important - fconfigure $img -translation binary - - # read in first two bytes - binary scan [read $img 2] "H4" byte1 - # check to see if this is a JPEG, all JPEGs start with "ffd8", make - # that SHOULD start with - if {$byte1!="ffd8"} { - close $img - error "$filename is not a valid JPEG file!" - } - - # cool, it's a JPG so let's loop through the whole file until we - # find the next marker. - while { ![eof $img]} { - while {$byte1!="ff"} { - binary scan [read $img 1] "H2" byte1 - } - - # we found the next marker, now read in the marker type byte, - # throw out any extra "ff"'s - while {$byte1=="ff"} { - binary scan [read $img 1] "H2" byte1 - } - - # if this the the "SOF" marker then get the data - if { ($byte1>="c0") && ($byte1<="c3") } { - # it is the right frame. read in a chunk of data - # containing the dimensions. - binary scan [read $img 7] "x3SS" height width - # return the dimensions in a list - close $img - return $width - } else { - # this is not the the "SOF" marker, read in the offset of the - # next marker - binary scan [read $img 2] "S" offset - # the offset includes its own two bytes so we need to subtract - # them - set offset [expr $offset -2] - # move ahead to the next marker - seek $img $offset current - } - - } - # we didn't find an "SOF" marker... - close $img - return 0 - } - - # From the Wiki! - proc pngsize {filename} { - if {[file size $filename] < 33} { - error "File $filename not large enough to contain PNG header" - } - set f [open $filename r] - fconfigure $f -translation binary - - # Read PNG file signature - binary scan [read $f 8] H* sig - if {[string compare $sig 89504e470d0a1a0a]} { - close $f - error "$filename is not a PNG file" - } - - # Read IHDR chunk signature - the length (0x0000000d) never - # changes, and the 49484452 should also always be there as it - # is the string "IHDR"! - binary scan [read $f 8] H* sig - if {[string compare $sig 0000000d49484452]} { - close $f - error "$filename is missing a leading IHDR chunk" - } - - # Read off the size of the image - binary scan [read $f 8] II width height - # Ignore the rest of the data, including the chunk CRC, since I have - # no convenient algorithm to verify it! - - #binary scan [read $f 5] ccccc depth type compression filter interlace - #binary scan [read $f 4] I chunkCRC - - close $f - return $width - } - - proc epswidth {filename} { - set f [open $filename r] - gets $f line - if {![string match %!PS-Adobe* $line]} {close $f; return 0} - if {![regexp EPSF $line]} {close $f; return 0} - set quad {0 0 -1 -1} - set land 0 - while {[string match %* $line]} { - gets $f line - switch -glob -- $line { - "%%BoundingBox: *" { - set quad [string range $line 15 end] - } - "%%Orientation: Landscape" { - set land 1 - } - "%%EndComments" - "%%BeginSetup" { - break - } - } - } - close $f - if {$land} { - return [expr {[lindex $quad 3]-[lindex $quad 1]+1}] - } else { - return [expr {[lindex $quad 2]-[lindex $quad 0]+1}] - } - } -} ADDED lib/conf_def.tcl Index: lib/conf_def.tcl ================================================================== --- /dev/null +++ lib/conf_def.tcl @@ -0,0 +1,239 @@ +### GENERAL CONFIGURATION OF THE CONFIGURATION CODE ### + +namespace eval configure { + + # For each value that this file describes how to configure... + # + # var_name var_type default_value documentation_string + # + # The default values will be [subst]ed before assignment, and this + # operation will be applied in order to the variables. + variable variables { + DOCDIR dir {} \ + "Path to directory containing TIP archive checked out of CVS" + EDITDIR dir {} "Path to directory to use for web editing" + BASETARG string _self "Name of target window for links in HTML" + BASEURL string {} \ + "URL which CGI script will operate as, with trailing '/'" + CSSURL string http://www.cs.man.ac.uk/~fellowsd/std.css \ + "URL for style sheet to apply to HTML" + ICONURL string http://www.tcl.tk/favicon.ico \ + "URL for link icon to apply to all HTML documents" + ENGINEURL string http://sourceforge.net/projects/tiprender/ \ + "URL for TIP Renderer project on SourceForge" + TCLLOGOURL string http://tcl.sourceforge.net/images/tclp.gif \ + "URL of Tcl logo image" + TCLLOGOX number 42 "Horizontal size of Tcl logo image" + TCLLOGOY number 64 "Vertical size of Tcl logo image" + TCLCOREMAIL string tcl-core@lists.sourceforge.net \ + "General email address for correspondence w.r.t. TIP contents" + FOOTERTEXT string "TIP AutoGenerator - written by Donal K. Fellows" \ + "Text footer of formatted pages; not HTML, must be HTML-safe" + LOGFILE file {} \ + "Path to log file (must be writable by CGI script)" + CVS_CLIENT file {[locateBinary cvs /usr/bin/cvs]} \ + "Path to cvs client binary" + SENDMAIL file {[locateBinary sendmail /usr/lib/sendmail]} \ + "Path to sendmail (or compatible) binary" + GS file {[locateBinary gs /usr/bin/gs]} \ + "Path to ghostscript binary" + PDFLATEX file {[locateBinary pdflatex /usr/bin/pdflatex]} \ + "Path to PDFLaTeX binary" + PUBLISHURL string http://purl.org/tcl/tip \ + "Base URL for publishing" + EDITURLBASE string http://purl.org/tcl/tip/edit \ + "Base URL for web editing" + CVSWEBURL string {[set BASEURL]history/%d} \ + "URL for cvsweb access; passed through format" + SENDMAILURL string {[set BASEURL]sendmail.html} \ + "URL for web-to-mail form to target" + TESTINGTIP number 10000 "Number of TIP used for testing" + ISSUEBASE string {https://sourceforge.net/support/tracker.php?aid=}\ + "(Partial) URL for where to look up bugs/patches" + + FEATURE(EDIT) boolean 0 "Support web editing" + COOKIEPATH string {[pathComponent $BASEURL /]} \ + "Path control value for cookies generated, with trailing '/'" + FEATURE(CVSWEB) boolean 1 "Support history inspection" + FEATURE(EDIT_URL_IN_NEWS_MESSAGE) boolean 1 \ + "Put edit URL in published news msgs" + FEATURE(EDIT_URL_HTML) boolean 1 "Put edit URL in HTML page" + FEATURE(PUBLISHING) boolean 0 \ + "Can publish announcements of new TIPs" + + history::infobg colour #80ff80 "Colour of log entries" + history::logbg colour #b0d0ff "Colour of history details" + history::addbg colour #80ff80 "Colour of added lines" + history::delbg colour #ffa0a0 "Colour of deleted lines" + } + + + # Which values are optional (configurable only if the -expert option is + # passed to makeconfig.tcl) as the defaults are typically good enough. + variable optional { + BASETARG CSSURL ICONURL ENGINEURL TCLLOGOURL TCLLOGOX TCLLOGOY + FOOTERTEXT ISSUEBASE + PUBLISHURL EDITURLBASE CVSWEBURL TESTINGTIP COOKIEPATH TCLCOREMAIL + FEATURE(EDIT) FEATURE(EDIT_URL_IN_NEWS_MESSAGE) FEATURE(PUBLISHING) + history::logbg history::infobg history::addbg history::delbg + SENDMAILURL + } + + + # Organize the values into pages (using a list of lists). The first + # element of each sublist is the title of the page/window, and the other + # elements are the variables to configure on that page. Note that the + # first page should usually be written pretty much as-is and the empty + # "variable" is actually not a variable at all but rather a way of putting + # a message up (its kind is always message) with the content of the + # message taken from the introMessage variable (below.) + # + # If the first variable on a page is optional, the whole page is optional. + variable pages { + { + "Configuring TIP Renderer" + "" + } + { + "Basic Locations" + DOCDIR EDITDIR BASEURL TCLCOREMAIL + } + { + "Self Advertising" + BASETARG CSSURL ICONURL ENGINEURL FOOTERTEXT TESTINGTIP + } + { + "Tcl Powered Logo" + TCLLOGOURL TCLLOGOX TCLLOGOY + } + { + "Editing Features" + EDITURLBASE CVSWEBURL FEATURE(EDIT) COOKIEPATH + } + { + "Publishing Features" + FEATURE(PUBLISHING) PUBLISHURL FEATURE(EDIT_URL_IN_NEWS_MESSAGE) + } + { + "Advanced Reporting" + FEATURE(CVSWEB) FEATURE(EDIT_URL_HTML) + } + { + "CVS-Web Colours" + history::infobg history::logbg history::addbg history::delbg + } + { + "Mail Control" + SENDMAILURL TCLCOREEMAIL + } + { + "Executables and Logs" + CVS_CLIENT SENDMAIL GS PDFLATEX LOGFILE + } + } + + + # Introductory message for the first page that the user sees. Should + # mention the -expert option and any other options that you define. + variable introMessage "Welcome to the TIP Rendering engine configuration\ + wizard. Please supply a value for all empty fields and check\ + that all other fields are set to sensible values. Many more\ + fields are available to edit if you start this script with the\ + -expert option. Once you have chosen values for everything,\ + this script will write a suitable config.tcl for you into the\ + current directory." + + + # String to write at the front of the configuration file. Contains bits + # that are needed always (typically things that are only ever configured + # by the code author). Leading whitespace from each line will be + # stripped... + variable header { + # Both $DOCDIR and $EDITDIR should be working directories checked out + # from the same CVS repository if web-editing is enabled. The CGI + # process needs write access to $EDITDIR, and commit privileges to + # CVS. $DOCDIR must be configured to receive updates each time a + # change is committed. + # (See Appendix C, Section C.7.2 of the CVS manual). + + set URI ??? + namespace eval ::history {} + + array set contenttypes { + .tip "text/x-tcl-tip; charset=iso-8859-1" + .html "text/html; charset=iso-8859-1" + .htm "text/html; charset=iso-8859-1" + .txt "text/plain; charset=iso-8859-1" + .patch "text/plain; charset=iso-8859-1" + .tex "application/x-latex; charset=iso-8859-1" + .xml "text/xml; charset=iso-8859-1" + .gif "image/gif" + .jpg "image/jpeg" + .jpeg "image/jpeg" + .jpe "image/jpeg" + .png "image/png" + .ppm "image/x-portable-pixmap" + .ps "application/postscript" + .eps "application/postscript" + .fig "application/x-fig" + .tcl "application/x-tcl; charset=iso-8859-1" + .dtd "application/xml-dtd; charset=iso-8859-1" + .xml "text/xml; charset=iso-8859-1" + .ms "application/x-troff; charset=iso-8859-1" + .rtf "text/rtf; charset=iso-8859-1" + } + + set renderable {} + set renderexts {} + foreach ext [array names contenttypes] { + if {[file exists $SRCDIR/tip[string trim $ext .].tcl]} { + lappend renderable $ext + lappend renderexts [string trim $ext .] + } + } + } + + catch { + if {[string match *Name:*.cs.man.ac.uk* \ + [exec nslookup [info hostname]]]} { + append header { + ### UGLY HACK ALERT! Fix access to suitable .cvspass file ### + set ::env(HOME) $SRCDIR/cvshack + if {[catch {exec $SRCDIR/cvshack/fix} msg]} { + puts "Content-Type: text/plain\n\nERROR: $msg" + exit + } + } + } + } +} + +### CODE THAT IS NEEDED FOR THIS PARTICULAR CONFIGURATION ### + +# Procedure to derive proper command paths from the name of the command and +# the current path (UNIX-specific.) +proc locateBinary {name fallback} { + global env + set pwd [pwd] + foreach dir [split $env(PATH) ":"] { + set fn [file join $pwd $dir $name] + if {[file isfile $fn] && [file executable $fn]} { + return $fn + } + } + return $fallback +} + +# Procedure to extract the path part of a URL. +proc pathComponent {url fallback} { + if {[regexp {^[^/]+//[^/]+(/.*)$} $url -> path]} { + return $path + } + return $fallback +} + +# Hack to make sure that setting variables directly into namespaces works... +namespace eval ::history {} + +# I like greys, and this undoes all sorts of CDE nastiness... +tk_setPalette grey85 ADDED lib/config.tcl Index: lib/config.tcl ================================================================== --- /dev/null +++ lib/config.tcl @@ -0,0 +1,110 @@ +# Points into local copy of CVS archive +set DOCDIR /home/fellowsd/lang/tcl/tip + +# Both $DOCDIR and $EDITDIR should be working directories checked out +# from the same CVS repository. The CGI process needs write access +# to $EDITDIR, and commit privileges to CVS. $DOCDIR must be +# configured to receive updates each time a change is committed. +# (See Appendix C, Section C.7.2 of the CVS manual). +##set DOCDIR $SRCDIR/tips +set EDITDIR $SRCDIR/tipedit + +set BASETARG _self +set BASEURL http://www.cs.man.ac.uk/fellowsd-bin/TIP/ +set CSSURL http://www.cs.man.ac.uk/~fellowsd/std.css +set ICONURL http://www.tcl.tk/favicon.ico +set ENGINEURL http://sourceforge.net/projects/tiprender/ +set TCLLOGOURL http://tcl.sourceforge.net/images/tclp.gif +# Size of image at above URL +set TCLLOGOX 42 +set TCLLOGOY 64 +set FOOTERTEXT "TIP AutoGenerator - written by Donal K. Fellows" +set URI ??? +set LOGFILE /home/fellowsd/lang/tcl/TIP/log +### More complex because I want to run on several platforms at once! +switch $tcl_platform(os) { + SunOS { + set CVS_CLIENT /home/fellowsd/arch/sparc-sun-solaris/bin/cvs + set SENDMAIL /usr/lib/sendmail + set GS /opt/cs/bin/gs + set PDFLATEX /opt/cs/bin/pdflatex + } + Linux { + set CVS_CLIENT /usr/bin/cvs + set SENDMAIL /usr/sbin/sendmail + set GS /usr/bin/gs + set PDFLATEX /usr/bin/pdflatex + } +} +# Separate, since might be a PURL +set PUBLISHURL http://purl.org/tcl/tip +# Separate, since might not reside on same server. +set EDITURLBASE http://purl.org/tcl/tip/edit +set CVSWEBURL ${BASEURL}history/%d +set TESTINGTIP 10000 +set COOKIEPATH /fellowsd-bin/TIP/ +set TCLCOREMAIL tcl-core@lists.sourceforge.net +set SENDMAILURL http://www.cs.man.ac.uk/fellowsd-bin/TIP/sendmail.html +set ISSUEBASE https://sourceforge.net/support/tracker.php?aid= + +array set FEATURE { + EDIT 0 + CVSWEB 1 + EDIT_URL_IN_NEWS_MESSAGE 1 + EDIT_URL_HTML 1 + PUBLISHING 1 +} + +### UGLY HACK ALERT! Gives access to suitable .cvspass file ### +set ::env(HOME) $SRCDIR/cvshack +set msg {} +foreach exe [list fix_$tcl_platform(machine)_$tcl_platform(os) fix] { + if {![catch {exec $SRCDIR/cvshack/$exe} msg]} { + break + } +} +if {[string length $msg]} { + puts "Content-Type: text/plain\n\nERROR: $msg" + exit +} + +namespace eval history { + # Assorted configurable parameters for the history management mechanism. + variable cmpurl compare + variable logbg #b0d0ff + variable infobg #80ff80 + variable addbg #80ff80 + variable delbg #ffa0a0 +} +array set contenttypes { + .tip "text/x-tcl-tip; charset=iso-8859-1" + .html "text/html; charset=iso-8859-1" + .htm "text/html; charset=iso-8859-1" + .txt "text/plain; charset=iso-8859-1" + .patch "text/plain; charset=iso-8859-1" + .tex "application/x-latex; charset=iso-8859-1" + .xml "text/xml; charset=iso-8859-1" + .gif "image/gif" + .jpg "image/jpeg" + .jpeg "image/jpeg" + .jpe "image/jpeg" + .png "image/png" + .ppm "image/x-portable-pixmap" + .ps "application/postscript" + .eps "application/postscript" + .fig "application/x-fig" + .tcl "application/x-tcl; charset=iso-8859-1" + .dtd "application/xml-dtd; charset=iso-8859-1" + .xml "text/xml; charset=iso-8859-1" + .ms "application/x-troff; charset=iso-8859-1" + .rtf "text/rtf; charset=iso-8859-1" +} + +set renderable {} +set renderexts {} +foreach ext [array names contenttypes] { + if {[file exists $SRCDIR/tip[string trim $ext .].tcl]} { + lappend renderable $ext + lappend renderexts [string trim $ext .] + } +} ADDED lib/cvs.tcl Index: lib/cvs.tcl ================================================================== --- /dev/null +++ lib/cvs.tcl @@ -0,0 +1,83 @@ +# FILE: cvs.tcl +# +# Routines that interface to the CVS client program and manage file locks + +proc acquireLock {tip} { + global EDITDIR + + # Write our lock file -- overwrite any left by prior owners of our pid + set lockFile [file join $EDITDIR .$tip.lock] + set myLockFile [file join $EDITDIR .$tip.[pid].lock] + set myReleaseFile [file join $EDITDIR .$tip.[pid].release] + file delete -- $myReleaseFile + set f [open $myLockFile w] + puts $f $myReleaseFile + close $f + + set tries 30 + while {[incr tries -1]} { + # Try to claim the lock by renaming our lock file to the lock + # file for the TIP we want to lock. Only one process can win + # this race. + if {![catch {file rename -- $myLockFile $lockFile}]} { + + # Here we might try setting up child process to release + # the lock in case we are killed before we release it. + # (CGI spec allows the CGI script to be killed at any time.) + + # We got the lock! acquireLock can return + return + } + + # Someone else holds the lock. Read it. + set f [open $lockFile] + set releaseFile [gets $f] + close $f + # How old is it? + if {![catch {file mtime $lockFile} lockTime] + && ([clock seconds] - $lockTime) > 120} { + # The lock is more than 5 minutes old. Assume that + # the process that acquired the lock died without + # releasing it. We'll release it instead. + # + # Release the lock file by renaming it so that only + # one process can succeed in releasing it. + catch {file rename -- $lockFile $releaseFile} + } + + # Wait a couple seconds, then try again to acquire the lock. + after 2000 + } + + # After several tries, we never acquired the lock + file delete -- $myLockFile + return -code error "could not acquire lock" +} + +proc releaseLock {tip} { + global EDITDIR + set lockFile [file join $EDITDIR .$tip.lock] + + # If a child process was launched as a safeguard to release + # our lock, cancel it. + + # Release my lock. + file delete -- $lockFile +} + +proc cvs {args} { + global EDITDIR CVS_CLIENT errorCode + + if {[catch { + cd $EDITDIR + uplevel 1 [linsert $args 0 exec $CVS_CLIENT -q] + } result]} { + # CVS writes lots of messages to stderr. Don't treat those + # messages as errors. Only raise an error on a non-zero exit + # status. + if {[string match CHILDSTATUS [lindex $errorCode 0]]} { + return -code error "$result (exit code was [lindex $errorCode 2])" + } + } + return $result +} ADDED lib/edit.tcl Index: lib/edit.tcl ================================================================== --- /dev/null +++ lib/edit.tcl @@ -0,0 +1,386 @@ +# FILE: edit.tcl +# +# Routines to manage the editing of a TIP via the web. + +proc setPOSTdefaults {array} { + global SRCDIR + upvar 1 $array h + + # When is the TIP available for editing through the web? + # If the State is Draft, and the vote is still pending. + # Might adjust these conditions to taste... + if {[notEditable? h]} { + refuseToEdit h + } + if {![info exists ::post::operation]} { + source $SRCDIR/post.tcl + } + + if {![info exists ::post::revision]} { + regexp {^\$([^:]+): (.*)\$$} $h(Version) -> keyword expansion + switch [string tolower $keyword] { + id { + regexp {tip,v ([0-9.]+)} $expansion -> ::post::revision + } + revision { + set ::post::revision [string trim $expansion] + } + default { + return -code error "Header field Version: must be\ + a CVS keyword expansion of Revision: or Id:" + } + } + } + + if {![info exists ::post::abstract]} { + set ::post::abstract $h(RawAbstract) + } + if {![info exists ::post::body]} { + set ::post::body [join $h(Body) \n\n] + } + if {![info exists ::post::log]} { + set ::post::log {} + } +} + +proc cookieHeader {key value} { + global EDITURLBASE COOKIEPATH + binary scan $value H* hexvalue + return "Set-Cookie: $key=$hexvalue; path=$COOKIEPATH;\ + expires=Sunday, 01-Jan-2034 00:00:00 GMT" + # Expires line is extracted from Netscrape cookie documentation... +} +proc getCookie {key} { + global cookie + set value {} + catch { + # Fails if malformatted or non-existant, but that's OK + set value [binary format H* $cookie($key)] + } + return $value +} + +proc editTIP {id} { + global DOCDIR URI + + set filename [file join $DOCDIR $id.tip] + if {![file readable $filename]} { + generr "Not Found" "that document is not available on this server." + } + + array set details [getTIPDetails $filename] + setPOSTdefaults details + switch -exact -- $::post::operation { + edit { + if {![string length $::post::email]} { + set ::post::email [getCookie tipwebEMAIL] + } + if {![string length $::post::name]} { + set ::post::name [getCookie tipwebNAME] + } + presentForm details + } + commit { + attemptCommit details + } + default { + generr "Invalid Request" "the request POST for URL $URI provided\ + invalid value '$::post::operation' for form variable\ + 'operation'." {} 403 + } + } +} + +proc refuseToEdit {array} { + global BASEURL CSSURL ICONURL FOOTERTEXT + upvar 1 $array h + + puts "Content-Type: text/html; charset=iso-8859-1" + puts "" + puts "" + puts "TIP #$h(TIP): Editing Refused" + puts "" + puts "" + puts "" + puts "" + puts "" + puts "" + puts "

    TIP #$h(TIP): $h(Title)

    " + + puts -nonewline "

    TIP #$h(TIP) may not be edited\ + through the web because " + if {[string match "In progress" $h(Vote)]} { + puts "a vote is in progress.

    " + } else { + puts "its State is $h(State).

    " + } + puts "

    View the current revision of \ + TIP #$h(TIP).

    " + puts "
    $FOOTERTEXT
    " + exit +} + +proc presentForm {array {msg ""}} { + global SRCDIR BASEURL FOOTERTEXT ENGINEURL + upvar 1 $array h + variable ::post::abstract + variable ::post::revision + variable ::post::body + variable ::post::email + variable ::post::name + variable ::post::log + + puts "Content-Type: text/html; charset=iso-8859-1\n" + source $SRCDIR/tiphtml.tcl + tiphtml::generateTIPHeader [array get h] + if {[string length $msg]} { + puts "

    $msg" + } + puts "

    Please enter your e-mail address (required),\ + your name (optional), make your edits to this TIP and its\ + Abstract, and Submit them. See TIP 3 for a description of the TIP\ + format.

    " + puts "

    You are advised to copy the text of\ + the TIP into an editor, make your edits there, and then paste\ + back.

    " + puts "
    " + puts "Name:
    E-mail:" + puts "" + puts "
    " + puts "" + puts "

    Abstract:" + puts "

    This is a supplement to the\ + main log message to allow you to add extra notes if you\ + wish.

    " + puts "
    " + puts "" + puts "
    Body:" + puts "" + puts "
    Log:

    Note that\ + when you submit this form, the server will attempt to store\ + your personal details (i.e. name and email address) as\ + cookies in your browser so that next time you edit a TIP, you\ + do not need to retype this info. We do not retain the information\ + on our server (other than as logged in the TIP itself and in\ + the CVS log) and you can delete it without ill-effect if you\ + wish. You are invited to study the\ + implementation code if you wish to understand exactly how\ + the information is stored in your browser.

    $FOOTERTEXT
    " + exit +} + +proc attemptCommit {array} { + global EmailRE EDITDIR BASEURL SRCDIR DOCDIR + upvar 1 $array h + + if {![regexp $EmailRE <$::post::email>]} { + presentForm h "You must provide a valid e-mail address!" + } + + set pars [splitIntoParagraphs [string trim $::post::body]] + + # Force Abstract into a single paragraph and heading and stick + # it at the beginning. + set pars [linsert $pars 0 "~ Abstract" [join [splitIntoParagraphs \ + [string trim $::post::abstract]] \n]] + + # Double-check we did that right... + if {[string compare {section Abstract 1} \ + [intuitParagraphKind [lindex $pars 0]]]} { + presentForm h "Each TIP must begin with an Abstract!" + } + + # For wiki-spam, we adopt an evil approach; we pretend that we've + # successfully checked in the change but in fact we've done + # nothing of the sort and just format the page that the user + # submitted so that it appears they were successful. + if {[isWikispam h $pars]} { + global COOKIEPATH + array set oldHeaders [getTIPDetails $DOCDIR/$h(TIP).tip] + set oldHeaders(Post-History) \ + "Wikispam detected: $why\ + Contact the\ + TIP Editor for help, including the change this TIP." + set ohpar [constructTIPHeader [array get oldHeaders]] + set data [formatTIPDocument $ohpar\n\n[join $pars \n\n]] + puts "Content-Type: text/html" + puts "Content-Length: [string length $data]" + puts [cookieHeader chongqid $::post::name] + puts "" + puts -nonewline $data + exit + } + + # Remove any CVS keyword expansion from the new TIP body to avoid + # conflict false alarms. + # + # At this point we could do any additional consistency or format + # checking on the new TIP body, and return bad TIPs to submitter + # for more editing. + # + set newBody [join $pars \n\n] + foreach keyword [list Author Date Header Id Name Locker Log RCSfile \ + Revision Source State] { + regsub -all -- \\$$keyword:?.*\\$ $newBody $$keyword$ newBody + } + + # Change to the working directory for editing, so cvs commands + # will work, and filenames can be relative. + cd $EDITDIR + + # OK, now comes the tricky part. We need exclusive access to the + # .tip file in $EDITDIR so we can update, merge, and commit the new + # changes in the TIP without interference from other CGI processes + # trying to do the same thing. So, we use a locking mechanism. + # See cvs.tcl for details. + source $SRCDIR/cvs.tcl + + # The next command will block until it can aquire the lock it needs. + if {[catch {acquireLock $h(TIP)}]} { + presentForm h "Could not acquire a lock on a working copy of\ + $h(TIP).tip. Please wait a moment and try your\ + submission again." + } + + # Retrieve from CVS the revision on which the new edits are based. + set file $h(TIP).tip + file delete -- $file + cvs update -r $::post::revision -kk $file + + # Replace the old body with the new body. Keep the old headers so we + # avoid any merging conflicts in the headers. +# set newTIP [constructTIPHeader [getTIPDetails $file]]\n\n[join $pars \n\n] + set newTIP [constructTIPHeader [getTIPDetails $file]]\n\n$newBody + file delete -- $file + set f [open $file w] + puts $f $newTIP + close $f + + # Merge in the other changes from the HEAD revision. Record whether + # there was a conflict, and read in the merged result. + set conflict [string match "*C $file*" [cvs update -A -kk $file]] + array set details [array get h] + array set details [getTIPDetails $file] + + # Add submitter as a new Author in headers, if necessary + set newAuthor 1 + foreach author $details(Author) { + if {[string match *<$::post::email>* $author]} { + set newAuthor 0 + break + } + } + if $newAuthor { + lappend details(Author) "$::post::name <$::post::email>" + set newTIP [constructTIPHeader [array get details]] + append newTIP "\n\n~ Abstract\n\n$details(RawAbstract)" + append newTIP \n\n[join $details(Body) \n\n] + file delete -- $file + set f [open $file w] + puts $f $newTIP + close $f + } + + if {$conflict} { + regexp {revision:[ \t]*([0-9.]+)} [cvs status $file] -> ::post::revision + + # After releasing the lock, send a form back to + # submitter to resolve the conflict. + set postReleaseScript { + unset ::post::abstract + unset ::post::body + setPOSTdefaults details + presentForm details "Your changes conflicted with changes from\ + someone else. Please resolve the conflict and submit\ + again." + } + + } else { + # No conflict. Try to commit the new revision to CVS + + set msg "Revision through web from $::post::name <$::post::email>" + if {[info exists ::post::log] && [string length $::post::log]} { + append msg "\n" [string trim $::post::log] + } + + if {[catch {cvs commit -m $msg $file} msg]} { + + # A failed 'cvs commit' after a successful 'cvs update' probably + # means another 'cvs commit' occurred (from somewhere other than + # the web interface) since our 'cvs update'. Try again. + set postReleaseScript { + attemptCommit h + } + + } else { + # Successful commit. + # Give it a second to push through, then redirect to the HTML + # rendering of the new revision. + set postReleaseScript { + after 2100 + puts "Location: $BASEURL$details(TIP).html" + puts [cookieHeader tipwebEMAIL $::post::email] + puts [cookieHeader tipwebNAME $::post::name] + puts "" + } + } + } + + releaseLock $h(TIP) + eval $postReleaseScript +} + +proc isWikispam {headerArray paragraphs {whyVar why}} { + upvar 1 $headerArray h $whyVar why + global DOCDIR + + # Spammers are lazy, real contributors are (usually) not. + + if {[llength [split $::post::name]] < 2} { + set why "short real name" + return 1 + } + + # Count the number of http urls in the original and the new + # version. Note that these searches are *very* simple-minded, but + # that should be enough. + + set old [getTIPFileContents [file join $DOCDIR $h(TIP).tip]] + set oldCount 0 + set idx 0 + while {[set idx [string first http: $old $idx]] >= 0} { + incr oldCount + incr idx + } + + set new [join $paragraphs] + set newCount 0 + set idx 0 + while {[set idx [string first http: $new $idx]] >= 0} { + incr newCount + incr idx + } + + # It's spam if more than two things that look vaguely like http + # URIs are added in a single update + if {$newCount > $oldCount + 2} { + set why "too many added URLs" + return 1 + } + return 0 +} ADDED lib/history.tcl Index: lib/history.tcl ================================================================== --- /dev/null +++ lib/history.tcl @@ -0,0 +1,192 @@ +source $SRCDIR/cvs.tcl + +proc history::logentries {file} { + set entries {} + set gotfirst 0 + set pattern1 ---------------------------- + set pattern0 ============================================================================= + foreach line [split [string trim [cvs log -N $file]] "\n"] { + if {[string match $pattern0 $line]} { + lappend entries $accum + break + } + if {[string match $pattern1 $line]} { + if {$gotfirst} { + lappend entries $accum + } else { + set gotfirst 1 + } + set accum {} + continue + } + lappend accum $line + } + set revisions {} + array set info {} + foreach entry $entries { + regexp {revision (.*)} [lindex $entry 0] -> revision + lappend revisions $revision + foreach kv [split [lindex $entry 1] ";"] { + set kv [string trim $kv] + if {![string length $kv]} {continue} + regexp {([^:]+): +(.*)} $kv -> key value + set info($revision,$key) $value + } + # Trim off unwanted lines + set log [lrange $entry 2 end] + while {[string match {branches: *;} [lindex $log 0]]} { + set log [lrange $log 1 end] + } + set info($revision,logmsg) [join $log "\n"] + } + return [list $revisions [array get info]] +} + +proc history::difflines {file r1 r2} { + set lines {} + set inheader 1 + set seppat @@*@@ + catch {cvs diff -u -b -r$r1 -r$r2 $file} msg + foreach line [split [string trim $msg] \n] { + if {[string match $seppat $line]} { + if {!$inheader} { + lappend lines sep + } else { + set inheader 0 + } + } elseif {!$inheader} { + regexp {(.)(.*)} $line -> type content + while {[regexp -indices "\t" $content tabpos]} { + set tabpos [lindex $tabpos 0] + set pre [string range $content 0 [expr {$tabpos-1}]] + set post [string range $content [expr {$tabpos+1}] end] + ### [string repeat] is not available in 8.0 + append pre " " + while {[string length $pre]%8} {append pre " "} + set content $pre$post + } + switch -- $type { + - {lappend lines [list del $content]} + + {lappend lines [list add $content]} + " " {lappend lines [list ctx $content]} + } + } + } + return $lines +} + +proc history::quoteEnt {string} { + regsub -all & $string {\&} string + regsub -all \" $string {\"} string + regsub -all < $string {\<} string + regsub -all > $string {\>} string + return $string +} +proc history::quoteEmail1 {string} { + global EmailRE + regsub -all $EmailRE $string "<\x80\\1\x81>" string + return $string +} +proc history::quoteEmail2 {string tip} { + while {[regexp -indices "\x80\[^\x80\x81\]+\x81" $string locn]} { + foreach {first last} $locn {} + set mail [string range $string [expr {$first+1}] [expr {$last-1}]] + foreach {user sys} [split $mail @] {break} + regsub -all {\.} $user " dot " user + regsub -all {\.} $sys " dot " sys + set newstring [string range $string 0 [expr {$first-1}]] + append newstring "$user at $sys" + set string $newstring[string range $string [expr {$last+1}] end] + } + return $string +} + +proc history::fmtlogentries {tipid} { + set loginfo [logentries $tipid.tip] + array set info [lindex $loginfo 1] + + variable infobg + variable logbg + + append puts "AuthorQuick Comparison\n" + set vs [lsort -dictionary [lindex $loginfo 0]] + foreach v $vs { + # hardcoded value! + if {![string compare $info($v,author) "tclhttpd"]} { + set info($v,author) "WebEdit" + } + append puts "$info($v,author)$info($v,date)\n" + append puts "\n" + append puts "\n" + append puts "\n" + } + append puts "" + append puts "
    VersionDate
    $vView this version
    Log Message
    \n"
+	set loglines [quoteEmail1 $info($v,logmsg)]
+	set loglines [join [split [quoteEnt $loglines] "\n"] "\n  "]
+	set loglines [quoteEmail2 $loglines $tipid]
+	append puts "  $loglines
    \n" + append puts "\n" + append puts "
    " +} + +proc history::fmtdifflines {tipid r1 r2} { + variable addbg + variable delbg + + set old {} + set lineinfo [difflines $tipid.tip $r1 $r2] + set maxl 0 + + if {![llength $lineinfo]} { + return "

    No differences or at least one version non-existent.

    " + } + + foreach line $lineinfo { + set len [string length [lindex $line 1]] + if {$len>$maxl} {set maxl $len} + } + append puts "
    \n"
+    foreach line $lineinfo {
+	set c [quoteEnt [format %-*s $maxl [lindex $line 1]]]
+	append puts $old
+	set old {}
+	switch [lindex $line 0] {
+	    sep {append puts "
    "}
+	    ctx {append puts "$c\n"}
+	    add {
+		append puts "$c\n"
+		set old ""
+	    }
+	    del {
+		append puts "$c\n"
+		set old ""
+	    }
+	    default {append puts ==$line==\n}
+	}
+    }
+    append puts "
    " +} + +proc history::fmtrevision {tipid revision} { + set document [cvs update -pr $revision $tipid.tip 2>/dev/null] + formatTIPDocument $document html $revision +} ADDED lib/mail.tcl Index: lib/mail.tcl ================================================================== --- /dev/null +++ lib/mail.tcl @@ -0,0 +1,176 @@ +#source $SRCDIR/post.tcl +namespace eval ::mail { + namespace export mailform mailformaccept mailsend + + proc row {c1 c2 args} { + if {[string length $c1]} { + puts -nonewline "$c1" + } else { + puts -nonewline "" + } + puts [eval [list format "$c2"] $args] + } + proc row_a {c1 c2 args} { + if {[string length $c1]} { + puts -nonewline "$c1" + } else { + puts -nonewline "" + } + puts [eval [list format "$c2"] $args] + } + + proc dotify {str} { + regsub -all {\.} $str " dot " str + return $str + } + + proc mailform {name user sys tipnum} { + global BASEURL CSSURL ICONURL DOCTYPE DOCDIR TCLCOREMAIL SENDMAILURL + if {![string length $name]} { + set syntheticName 1 + set hname "${user}_at_${sys}" + set name [dotify "$user at $sys"] + } else { + set hname $name + } + puts "Content-Type: text/html; charset=iso-8859-1" + puts "" + puts $DOCTYPE + puts "Compose Mail to $hname About\ + TIP#$tipnum" + puts "" + puts "" + puts "" + puts "" + puts "" + puts "" + puts "

    Composing Email Message to $name About TIP#$tipnum

    " + puts "
    " + set hide [list user $user sys $sys tipnum $tipnum] + if {![info exist syntheticName]} { + lappend hide name $name + } + row From: "" + row "" "

    Please note that you will be Cc'ed with\ + whatever message you create here, so you can retain a record\ + of your messages if you wish.

    " + row To: "%s <%s at %s>" \ + $name [dotify $user] [dotify $sys] + foreach {tc_user tc_sys} [split $TCLCOREMAIL @] {break} + if { + [string compare $user $tc_user] || + [string compare $sys $tc_sys] + } then { + row "" " Send Cc: to %s at %s" \ + [dotify $tc_user] [dotify $tc_sys] + } + if {[regexp {^[0-9]+$} $tipnum]} { + array set tipd [getTIPDetails [file join $DOCDIR $tipnum.tip]] + row Subject: "Re: TIP#%d: %s" $tipnum $tipd(Title) + lappend hide subject "Re: TIP#${tipnum}: $tipd(Title)" + } else { + row Subject: "" + } + row_a Body: "" + puts "
     
    " + if {[info exist ::env(HTTP_REFERER)]} { + lappend hide ref $::env(HTTP_REFERER) + } else { + lappend hide ref $BASEURL/$tipnum + } + foreach {key val} $hide { + regsub -all & $val {\&} val + regsub -all < $val {\<} val + regsub -all > $val {\>} val + regsub -all \" $val {\"} val + puts "" + } + puts -nonewline "
    " + basicHTMLfooter + exit + } + + proc mailformaccept {} { + variable ::post::name ;#"NO NAME" + variable ::post::user ;#no.name + variable ::post::sys ;#all + variable ::post::tipnum ;#-1 + variable ::post::from ;#test@foo.bar + variable ::post::subject ;#TEST + variable ::post::body ;#"TESTING...\r\n1, 2, 3, 4, 5\r\n" + variable ::post::ref ;#$::BASEURL + variable ::post::cccore ;#{} + + if {![regexp {^[^,]+@[^,]+\.[^,]+$} $from]} { + generr "Bad From Email Address" \ + "this system will not send mail purporting to come\ + from $from" + } + if {[regexp {[^a-zA-Z0-9_.]} $user]||[regexp {[^a-zA-Z0-9_.]} $sys]} { + generr "Bad To Email Address" \ + "this system will not send mail to [dotify $user] at [dotify $sys]" + } + + #::post::getVars + set cccore [expr {[info exist cccore] && [string length $cccore]}] + if {![info exist name]} { + set name {} + } + # Apply the CRLF->LF translation ourselves + regsub -all "\r\n" $body "\n" body + processmail $name $user $sys $tipnum $from $subject $body $ref $cccore + } + + proc addmailhdr {var key val} { + # Effectively a sanitised append + upvar 1 $var v + regsub -all "\[\r\n\t \]+" $val " " val + append v "${key}: $val\n" + } + proc processmail {name user sys tipnum from subject body ref cccore} { + global env TCLCOREMAIL + + set hdr "" + addmailhdr hdr From $from + addmailhdr hdr Cc $from + addmailhdr hdr To "$name <$user@$sys>" + addmailhdr hdr Subject $subject + if {$cccore} { + addmailhdr hdr Cc $TCLCOREMAIL + } + addmailhdr hdr Errors-To donal.fellows@man.ac.uk + addmailhdr hdr X-Tip-Number $tipnum + addmailhdr hdr MIME-Version 1.0 + addmailhdr hdr Content-Type {text/plain; charset=iso-8859-1} + addmailhdr hdr Content-Transfer-Encoding 8bit + addmailhdr hdr Date [clock format [clock seconds] -gmt 1 -format \ + "%a, %d %b %Y %H:%M:%S +0000\n"] + addmailhdr hdr X-Note "Message generated through web interface" + catch {addmailhdr hdr X-Submitting-Ip $env(REMOTE_ADDR)} + catch {addmailhdr hdr X-Submitting-User-Agent $env(HTTP_USER_AGENT)} + + mailsend $hdr\n[string trim $body \n]\n + + # Redirect back to where we originally came from + puts "Location: $ref\n" + } + + proc mailsend {message {redir 0}} { + global SENDMAIL + if {$redir} { + exec $SENDMAIL -oi -t <<$message >@stdout 2>@stderr + } else { + exec $SENDMAIL -oi -t <<$message + } + } +} ADDED lib/parse.tcl Index: lib/parse.tcl ================================================================== --- /dev/null +++ lib/parse.tcl @@ -0,0 +1,450 @@ +#! /usr/local/bin/tclsh8.0 + +# Regular expressions - suitable for 8.0 as well as later. +set ws "\[ \t\n\]" +set ParSepRE "^$ws*$" +set RFC822ContRE "^$ws" +set RFC822DataRE "^(\[^ \t:\]+):$ws+(.*)$" +set RFC822EmptyRE "^(\[^ \t:\]+):$" +set ItemNoLeadRE "^\[^ \t>\]" +set ItemLeadRE "^$ws*((>$ws+)*)(\\*|\[0-9\]+\\.|(\[^\t\n:\]|:\[^:\t\n\])+:)$ws" +set ItemContRE "^($ws+>)+$ws*" +# RE's for (optional) use in paragraphs +set AuthorRE "(.*$ws+)?<(\[^:@\]+@\[^:@\]+)>" +set ImageRE "^(\[^ \t\n\]+)$ws*(.*)$" +set EmailRE {<([^<>@]+@[^<>@]+)>} +set URLRE {(https?|ftp|news(rc)?|mailto|gopher):([-A-Za-z0-9/_:.%#+@?=&;~\\]+)} +set TIPURLRE {tip:([0-9]+)} +set ShortTIPRE {\[([0-9]+)\]} +set ISSUEURLRE {issue:([0-9]+)} + +# # Regular expressions - suitable for 8.1 and later only. It is easier to +# # understand the above by looking at the below and translating... :^) +# +# set ParSepRE {^\s*$} +# set RFC822ContRE {^\s} +# set RFC822DataRE {^([^\s:]+):\s*(.*)$} +# set RFC822EmptyRE {^([^\s:]+):\s*$} +# set ItemNoLeadRE {^[\s>]} +# set ItemLeadRE {^\s*((>\s+)*)(\*|\d+\.|(?:[^\t\n:]|:(?=\S))+:)\s} +# set ItemContRE {^(\s+>)+\s*} +# # RE's for (optional) use in paragraphs +# set AuthorRE {(.*\s+)?<(.*?@.*)>} +# set ImageRE {^(\S+)\s*(.*)$} +# set EmailRE {<([^<>@]+@[^<>@]+)>} +# set URLRE {(https?|ftp|news(?:rc)?|mailto|gopher):([-A-Za-z0-9/_:.#+@?=&;~\\]+)} +# set TIPURLRE {tip:(\d+)} +# set ShortTIPRE {\[(\d+)\]} +# set ISSUEURLRE {issue:(\d+)} +# +# # Note that ItemLeadRE would be clearer if written as: +# # ^\s*((?:>\s+)*)(\*|\d+\.|(?:[^\t\n:]|:(?=\S))+:)\s +# # but that would be incompatible with the 8.0 version. + +proc splitIntoParagraphs {string} { + global ParSepRE + set paragraphs {} + set current {} + foreach line [split $string "\n"] { + if {[regexp $ParSepRE $line]} { + # (VISUALLY) BLANK LINE = PARAGRAPH SEPARATOR + if {[string length $current]} { + lappend paragraphs [string trim $current "\n"] + set current {} + } + continue + } + append current "\n$line" + } + if {[string length $current]} { + lappend paragraphs [string trim $current "\n"] + } + return $paragraphs +} + +proc splitRFC822Header {paragraph} { + global RFC822ContRE RFC822DataRE RFC822EmptyRE + set properlines {} + set current {} + foreach line [split $paragraph "\n"] { + if {[regexp $RFC822ContRE $line]} { + append current $line + continue + } + if {[string length $current]} { + if {[regexp $RFC822DataRE $current -> tag value]} { + lappend properlines $tag $value + } elseif {[regexp $RFC822EmptyRE $current -> tag]} { + lappend properlines $tag {} + } else { + return -code error "header \"$current\" malformatted" + } + } + set current $line + } + if {[string length $current]} { + if {[regexp $RFC822DataRE $current -> tag value]} { + lappend properlines $tag $value + } elseif {[regexp $RFC822EmptyRE $current -> tag]} { + lappend properlines $tag {} + } else { + return -code error "header \"$current\" malformatted" + } + } + return $properlines +} + +proc TIPHeaderSpecification {permitted required} { + upvar 1 $permitted formatREs $required neededHeaders + # A header is only permitted if it is a key in this array, and the value + # in the array is the regexp that the value in the field (after + # un-stuffing) must satisfy. + array set formatREs { + TIP {^[0-9]+$} + Title {.} + Version {^\$.*\$ *$} + Author {<.+@.+\..+>} + State {^(Draft|Active|Accepted|Deferred|Final|Rejected|Withdrawn)$} + Type {^(Process|Project|Informati(ve|on(al)?))$} + Vote {^(Pending|In progress|Done|No voting)$} + Created {^[0-3][0-9]-[A-Z][a-z][a-z]-2[0-9][0-9][0-9]$} + Post-History {.*} + Tcl-Version {^[0-9]+\.[0-9]+([ab.][0-9]+)?$} + Discussions-To {.} + Obsoletes {^[0-9]+$} + Obsoleted-By {^[0-9]+$} + Keywords {.} + Vote-By {^[0-9]+$} + Voted-For {.} + Voted-Against {.} + Voted-Abstained {.} + } + # A list of headers that *must* be present in a conforming TIP. + set neededHeaders { + TIP Title Version Author State Type Vote Created Post-History + } + ## Headers that may occur multiple times in a conforming TIP. All others + ## must occur at most once. + #set multipleHeaders { + # Author + #} +} + +# takes output of splitRFC822Header +proc verifyTIPheader {headerlines} { + array set headers {} + TIPHeaderSpecification permitted required + + foreach {tag value} $headerlines { + if {![info exists permitted($tag)]} { + return -code error "header \"${tag}: $value\" not understood" + } + if {![regexp $permitted($tag) $value]} { + return -code error "header \"${tag}: $value\" malformatted" + } + if {[string compare $tag Author]} { + if {[info exists headers($tag)]} { + return -code error "header for \"${tag}:\" can only occur once" + } + set headers($tag) $value + } else { + lappend headers($tag) $value + } + } + foreach tag $required { + if {![info exist headers($tag)]} { + return -code error "header for \"${tag}:\" is required" + } + } + if {[string match Info* $headers(Type)]} { + set headers(Type) Informative + } + if {[info exist headers(Keywords)]} { + set kws {} + foreach keyword [split $headers(Keywords) ","] { + regsub -all "\[ \t\n\]+" $keyword " " keyword + lappend kws [string trim $keyword] + } + set headers(Keywords) $kws + } + # This check is complex... + if {[info exist headers(Tcl-Version)] != ![string compare $headers(Type) Project]} { + return -code error "header \"Tcl-Version:\" iff a project TIP" + } + # Force the created header into processable form + regsub -all -- (.+)-(.+)-(.+) $headers(Created) {\2 \1, \3} date + set headers(Created) [clock scan $date -gmt 1] + # Now return as association list + return [array get headers] +} + +proc makeHeaderLine {tag value} { + set line $tag: + set numSpaces [expr {16 - [string length $tag]}] + while {[incr numSpaces -1]} { + append line " " + } + append line $value + return $line +} + +proc constructTIPHeader {headerData} { + array set headers $headerData + # Remove RawAbstract, Abstract and Body entries, if any + catch {unset headers(RawAbstract)} + catch {unset headers(Abstract)} + catch {unset headers(Body)} + + TIPHeaderSpecification permitted required + set headerLines [list] + foreach tag $required { + if {![info exists headers($tag)]} { + return -code error "header for \"${tag}\" is required" + } + set value $headers($tag) + # Created tag needs restoration to standard form + if {[string match Created $tag]} { + set value [clock format $value -format %d-%b-%Y -gmt 1] + } + if {![regexp $permitted($tag) $value]} { + return -code error "header \"${tag}: $value\" malformatted" + } + # Author tag needs special handling + if {[string match Author $tag]} { + foreach author $value { + if {![regexp $permitted($tag) $author]} { + return -code error "header \"${tag}: $value\" malformatted" + } + lappend headerLines [makeHeaderLine Author $author] + } + unset headers($tag) + continue + } + lappend headerLines [makeHeaderLine $tag $value] + unset headers($tag) + } + foreach tag [lsort [array names headers]] { + if {![info exists permitted($tag)]} { + return -code error "header \"${tag}: $value\" not understood" + } + set value $headers($tag) + if {![regexp $permitted($tag) $value]} { + return -code error "header \"${tag}: $value\" malformatted" + } + if {[string match Keywords $tag]} { + lappend headerLines [makeHeaderLine $tag [join $value ","]] + } else { + lappend headerLines [makeHeaderLine $tag $value] + } + } + return [join $headerLines \n] +} + +proc notEditable? {headerArray} { + upvar 1 $headerArray h + expr {[string compare Draft $h(State)]||[string compare Pending $h(Vote)]} +} + +proc shortspc {string} { + regsub -all {[ + ]+} $string " " string + return $string +} +proc intuitParagraphKind {paragraph} { + switch -glob -- $paragraph { + ~* { + # easier to express in 8.1 as {^((?:~ *){1,3})(.*)} + regexp {^(~( *~)?( *~)?) *(.*)$} $paragraph -> \ + levelmark ? ? content + # Count the number of tildes in the level-mark + set level [regsub -all ~ $levelmark x levelmark] + return [list section [string trim [shortspc $content]] $level] + } + |* { + set lines {} + foreach line [split $paragraph "\n"] { + if {![string match |* $line]} { + variable DEBUG_VERBATIM + if {$DEBUG_VERBATIM} { + return -code error "malformatted verbatim line \"$line\"" + } + lappend lines $line + } else { + lappend lines [string range $line 1 end] + } + } + return [list verbatim $lines] + } + #index:* { + set type [string trim [string range $paragraph 7 end]] + if {![string length $type]} {set type medium} + return [list index $type] + } + #image:* { + return [list image [string range $paragraph 7 end]] + } + ---- { + return {separator} + } + } + + global ItemNoLeadRE ItemLeadRE ItemContRE + + # Hmm. Need to figure out if we've got a list item of some kind. + if {[regexp $ItemNoLeadRE $paragraph]} { + return [list ordinary [shortspc $paragraph]] + } + if {[regexp $ItemLeadRE $paragraph head continuation ? kind]} { + set content [string range $paragraph [string length $head] end] + set level [llength $continuation] + switch -glob -- $kind { + *: { + set kind [string trimright $kind ":"] + return [list description $kind $level [shortspc $content]] + } + *. { + set kind [string trimright $kind "."] + return [list enumeration $kind $level [shortspc $content]] + } + } + return [list bulleting $level [shortspc $content]] + } + if {[regexp $ItemContRE $paragraph head]} { + set content [string range $paragraph [string length $head] end] + return [list continuation [llength $head] [shortspc $content]] + } + return [list ordinary [shortspc $paragraph]] +} + +array set contentsCache {} +proc getTIPFileContents {filename} { + global contentsCache + if {[info exist contentsCache($filename)]} { + return $contentsCache($filename) + } + set f [open $filename r] + set content [read $f [file size $filename]] + close $f + set contentsCache($filename) $content +} +proc readTIPDetailsFromFile {filename} { + variable DEBUG_VERBATIM + if {![info exist DEBUG_VERBATIM]} { + set DEBUG_VERBATIM 0 + } + set pars [splitIntoParagraphs [getTIPFileContents $filename]] + foreach {headers title abstract} $pars {break} + set heads [verifyTIPheader [splitRFC822Header $headers]] + if {[string compare [intuitParagraphKind $title] {section Abstract 1}]} { + error "Must start with abstract..." + } + lappend heads Abstract [lindex [intuitParagraphKind $abstract] 1] + lappend heads RawAbstract $abstract + lappend heads Body [lrange $pars 3 end] +} +array set tipdetails {} +proc getTIPDetails {filename} { + global tipdetails contentsCache + if {![info exist tipdetails(time:$filename)] + || ([file mtime $filename] > $tipdetails(time:$filename))} { + set tipdetails(time:$filename) [file mtime $filename] + catch {unset contentsCache($filename)} + set tipdetails(file:$filename) [readTIPDetailsFromFile $filename] + } + return $tipdetails(file:$filename) +} +proc getTIPFilenames {} { + global DOCDIR FEATURE TESTINGTIP + cd $DOCDIR + set tips [lsort -dictionary [glob *.tip]] + # Assume the testing TIP (only visible when editing enabled) is at end! + if { + !$FEATURE(EDIT) && + ![string compare [lindex $tips end] ${TESTINGTIP}.tip] + } then { + # Don't remove TIP 10000 if editing is enabled. + set tips [lreplace $tips end end] + } + return $tips +} +proc foreachTIP {arrayname script} { + upvar 1 $arrayname ary + foreach file [getTIPFilenames] { + array set ary [getTIPDetails $file] + uplevel 1 $script + unset ary + } +} +proc foreachTIPreverse {arrayname script} { + upvar 1 $arrayname ary + set files [getTIPFilenames] + for {set idx [llength $files]} {[incr idx -1] >= 0} {} { + array set ary [getTIPDetails [lindex $files $idx]] + uplevel 1 $script + unset ary + } +} + +proc convert {in out {type html}} { + set cwd [pwd] + set document [formatTIPDocument [getTIPFileContents $in] $type] + + set fout [open [file join $cwd $out] w] + puts -nonewline $fout $document + flush $fout + close $fout +} + +proc formatTIPDocument {string {type html} args} { + global SRCDIR + set ns tip${type} + source $SRCDIR/$ns.tcl + + variable DEBUG_VERBATIM + if {![info exist DEBUG_VERBATIM]} { + set DEBUG_VERBATIM 0 + } + set pars [splitIntoParagraphs $string] + set heads [verifyTIPheader [splitRFC822Header [lindex $pars 0]]] + set par1 [intuitParagraphKind [lindex $pars 1]] + if {[string compare $par1 {section Abstract 1}]} { + array set h $heads + return -code error "TIP $h(TIP) must start with abstract..." + } + + global convert + set convert {} + proc ${ns}::puts {args} { + global convert + switch [llength $args] { + 2 {append convert [lindex $args 1]} + 1 {append convert [lindex $args 0] "\n"} + } + } + if {[llength $args]} { + ${ns}::generateDocument $heads [lrange $pars 1 end] $args + } else { + ${ns}::generateDocument $heads [lrange $pars 1 end] + } + + return $convert +} + +if {![info exist SRCDIR]} { + set SRCDIR [file join [pwd] [file dirname [info script]]] + source $SRCDIR/config.tcl + + append convertRE {^([0-9]+).} ([join $renderexts |]) {$} + if {[regexp $convertRE [lindex $argv 0] out id type]} { + catch { + set src [file join $DOCDIR $id.tip] + puts -nonewline "converting $src to $out..." + flush stdout + convert $src $out $type + puts " done" + exit + } + puts $errorInfo + exit 1 + } +} ADDED lib/post.tcl Index: lib/post.tcl ================================================================== --- /dev/null +++ lib/post.tcl @@ -0,0 +1,65 @@ +# FILE: post.tcl +# +# Routines to process the HTTP POST method, gathering HTML form input +# values from stdin, and storing it in namespace variables post::* . + +namespace eval post { + variable operation edit + variable email "" + variable name "" +} + +proc post::UrlDecode {str} { + regsub -all {\+} $str { } str + regsub -all {[][\\\$]} $str {\\&} str + regsub -all {%([0-9a-fA-F][0-9a-fA-F])} $str {[format %c 0x\1]} str + set str [subst $str] + regsub -all "\r\n" $str "\n" str + return $str +} + +# Local variables in this proc have a leading underscore so they do +# not interfere with the namespace variables. +proc post::getVars {{env env}} { + upvar #0 $env _e + upvar #0 URI _URI + + if {![info exists _e(CONTENT_TYPE)]} { + generr "Bad Request" "the request $_e(REQUEST_METHOD) for URL\ + $_URI did not provide a Content-Type." {} 400 + } + if {![info exists _e(CONTENT_LENGTH)] + || ![regexp {^[0-9]+$} [string trim $_e(CONTENT_LENGTH)]]} { + generr "Bad Request" "the request $_e(REQUEST_METHOD) for URL\ + $_URI did not provide a valid Content-Length." {} 411 + } + if {[string compare application/x-www-form-urlencoded $_e(CONTENT_TYPE)]} { + generr "Unsupported Request" "the request $_e(REQUEST_METHOD) for URL\ + $_URI provided Content-Type '$_e(CONTENT_TYPE)' instead of \ + 'application/x-www-form-urlencoded'." {} 415 + } + set _query [read stdin $_e(CONTENT_LENGTH)] + foreach _def [split $_query &] { + set _pair [split $_def =] + if {[llength $_pair] != 2} { + generr "Bad Request" "the request $_e(REQUEST_METHOD) for URL\ + $_URI provided improperly encoded form data" {} 400 + } + set _varName [UrlDecode [lindex $_pair 0]] + if {[string match _* $_varName]} { + generr "Forbidden Request" "the request $_e(REQUEST_METHOD) for\ + URL $_URI provided form variables with leading underscores." \ + {} 403 + } + if {[regexp {[^a-zA-Z0-9_]} $_varName]} { + generr "Forbidden Request" "the request $_e(REQUEST_METHOD) for\ + URL $_URI provided form variables containing non-alphanumeric\ + characters." {} 403 + } + variable $_varName + set $_varName [UrlDecode [lindex $_pair 1]] + } + + # Disable multiple calls of this command + rename [lindex [info level 0] 0] {} +} ADDED lib/render/html.tcl Index: lib/render/html.tcl ================================================================== --- /dev/null +++ lib/render/html.tcl @@ -0,0 +1,948 @@ +namespace eval tiphtml { + variable curlev -1 + variable contexts {} + variable nextrefcounter 0 + + proc codechar {c} { + scan $c %c char + format %%%02x [expr {$char & 0xff}] + } + proc formcode {key args} { + regsub -all {[^a-zA-Z0-9]} [join $args] {[codechar \\&]} str + return $key=[subst $str] + } + proc nextrefnum {} { + variable nextrefcounter + incr nextrefcounter + } + proc xformdots {str} { + regsub -all {[.]} $str " dot " str + return $str + } + proc xformmailto {str {tip {}}} { + global BASEURL + set url ${BASEURL}mail.html? + regsub -all {[];${}\\[]} $str {\\&} str + # Make nameless subst + regsub -all "href=\"mailto:(\[^@]+)@(\[^\",]+)\"" $str \ + "href=\"$url\[formcode user \\1],\[formcode sys\ + \\2],tipnum=$tip\"" str + # Make named subst + regsub -all "href=\"mailto:(\[^@]+)@(\[^\",]+),(\[^\"]+)\"" $str \ + "href=\"$url\[formcode user \\1],\[\ + formcode sys \\2],\[formcode name \\3],tipnum=$tip\"" str + # Perform substitutions + subst $str + } + proc xformauthor {name email tip {longFmt 0}} { + set name [string trim $name] + foreach {user sys} [split $email @] {break} + set user [xformdots $user] + set sys [xformdots $sys] + if {$longFmt} { + if {[string length $name]} { + set link "$name <${user} at ${sys}>" + } else { + set link "${user} at ${sys}" + } + } elseif {[string length $name]} { + set link "$name" + } else { + set link "$user at $sys" + } + return [xformmailto $link $tip] + } + + proc enterlistcontext {level good bad1 bad2} { + variable curlev + variable contexts + if {$level > $curlev} { + incr curlev + lappend contexts "" + puts -nonewline "<$good compact>" + } + switch [lindex $contexts end] "" - "" { + puts -nonewline [lindex $contexts end] + puts -nonewline "<$good compact>" + set contexts [lreplace $contexts end end ""] + } + } + proc closecontext {{level -1}} { + variable curlev + variable contexts + while {$level < $curlev} { + incr curlev -1 + puts -nonewline [lindex $contexts end] + set contexts [lrange $contexts 0 [expr {[llength $contexts]-2}]] + } + } + proc quoteLiteral {string} { + # In 8.3 or later, we'd use [string map] for this. But this + # code has to work with 8.0 so we're stuck with [regsub -all] + regsub -all & $string {\&} string + regsub -all < $string {\<} string + regsub -all > $string {\>} string + regsub -all \" $string {\"} string + regsub -all \xa0 $string {\ } string + return $string + } + + proc section {title {level 1}} { + closecontext + incr level + puts "[quoteLiteral $title]" + } + proc ordinary {string} { + continuation -1 $string + } + proc bulleting {level body} { + closecontext $level + enterlistcontext $level ul ol dl + puts -nonewline "
  • " + continuation $level $body + } + proc description {tag level body} { + closecontext $level + enterlistcontext $level dl ol ul + puts -nonewline "
    $tag
    " + continuation $level $body + } + proc enumeration {tag level body} { + closecontext $level + enterlistcontext $level ol dl ul + if {$tag != 1} { + puts -nonewline "
  • " + } else { + puts -nonewline "
  • " + } + continuation $level $body + } + proc continuation {level body} { + global EmailRE URLRE TIPURLRE ShortTIPRE BASEURL ISSUEBASE ISSUEURLRE + variable thisTIPnumber + + closecontext $level + regsub -all $EmailRE $body "\x81mailto:\\1\x82" body + regsub -all $TIPURLRE $body "$BASEURL\\1.html" body + regsub -all $ISSUEURLRE $body "$ISSUEBASE\\1" body + set body [quoteLiteral $body] + + #regsub -all {[][\\ $;]} $body {\\&} body + #regsub -all $URLRE $body "\[addwbr &\]" body + #set body [subst -novar $body] + regsub -all {\[\[} $body \x83 body + regsub -all {\]\]} $body \x84 body + regsub -all \\\[($URLRE)\\\] $body "\x83\x85\x84" body + regsub -all $URLRE $body "&" body + + regsub -all {'''(('?[^'])+)'''} $body "\x87\\1" body + regsub -all {''(('?[^'\x87])+)''} $body "\\1" body + regsub -all $ShortTIPRE $body "TIP #\\1" body + regsub -all {\[} $body \x83 body + regsub -all {\]} $body \x84 body + #mail address monkeying... + if {[info exist thisTIPnumber]} { + set body [xformmailto $body $thisTIPnumber] + } else { + set body [xformmailto $body] + } + regsub -all {>mailto:([^][{};\\$<>@]+)@([^][{};\\$<>@]+)<} $body \ + ">\[xformdots \\1\] at \[xformdots \\2\]<" body + regsub -all \x85 $body {[nextrefnum]} body + regsub -all \x81 [subst -novar -noback $body] "\\<" body + regsub -all \x82 $body "\\>" body + regsub -all \x83 $body \[ body + regsub -all \x84 $body \] body + regsub -all \x86 $body : body + regsub -all \x87 $body {} body + variable curlev + if {$curlev==-1 && $level==1} { + puts "

    $body

    " + } else { + puts "

    $body

    " + } + } + proc separator {} { + closecontext + puts "
    " + } + proc verbatim {lines} { + puts "
    "
+	foreach line $lines {
+	    # HTML ignores formfeed chars, but we want to see them...
+	    regsub -all {} [quoteLiteral $line] "^L" line
+	    puts $line
+	}
+	puts -nonewline "
    " + } + + # Helpers to generate 'long' style indices + proc tr {c1 c2 {size 1}} { + puts -nonewline "$c1" + puts "$c2" + } + proc longidx {tpat {srch ""} {searchbody 0}} { + set matched 0 + if {[string match 8.0* [info tclversion]] && [string length $srch]} { + regsub -all {[^a-zA-Z0-9]} $srch {\\&} RE + } else { + set RE ***=$srch + } + foreachTIP d { + # must match type pattern and + if { + ![string match $tpat [string tolower $d(Type)]] || + ([string length $srch] && + ![regexp $RE "TIP #$d(TIP): $d(Title)"] && + (![info exist d(Keywords)] || + [lsearch -regexp $d(Keywords) $RE] < 0) && + ![regexp $RE $d(Abstract)] && + (!$searchbody || [lsearch -regexp $d(Body) $RE] < 0)) + } then { + continue + } + set matched 1 + puts "

    " + + puts -nonewline "" + puts "TIP #$d(TIP):\ + $d(Title)" + puts "
    $d(Version)
    " + ordinary $d(Abstract) + puts "
    " + + puts "
    " + set at "Author:" + global AuthorRE + foreach a $d(Author) { + regexp "^$AuthorRE" $a -> name mail + tr $at [xformauthor $name $mail $d(TIP)] + #tr $at "$name" + set at "" + } + tr Type: $d(Type) + if {[info exist d(Tcl-Version)]} { + tr "Tcl Version:" $d(Tcl-Version) + } + tr State: $d(State) + tr Vote: $d(Vote) + tr Created: [clock format $d(Created) -format "%d %b %Y" -gmt 1] + tr "Posting History:" [join [split $d(Post-History) ","] "
    "] + if {[info exist d(Discussions-To)]} { + set dtlink {} + foreach dt [split $d(Discussions-To) ,] { + regsub "^(mailto|news):" $dt "" dtnproto + lappend dtlink "$dtnproto" + } + tr "Discussions To:" [join $dtlink "
    "] + } + if {[info exist d(Obsoletes)]} { + tr Obsoletes: "TIP #$d(Obsoletes)" + } + if {[info exist d(Obsoleted-By)]} { + tr "Obsoleted By:" "TIP #$d(Obsoleted-By)" + } + if {[info exist d(Vote-By)]} { + if {$d(Vote-By) > [clock seconds]} { + tr Vote: [clock format $d(Vote-By) -gmt 1 \ + -format "%d %b %Y, %H:%M GMT"] + } else { + tr Vote-By: [clock format $d(Vote-By) -gmt 1 \ + -format "%d %b %Y, %H:%M GMT (closed)"] + } + } + if {[info exist d(Votes-For)]} { + tr Votes-For: $d(Votes-For) + } + if {[info exist d(Votes-Against)]} { + tr Votes-For: $d(Votes-For) + } + if {[info exist d(Votes-Abstained)]} { + tr Votes-For: $d(Votes-For) + } + if {[info exist d(Keywords)]} { + set kws {} + set kwl 0 + set comma "" + foreach k $d(Keywords) { + append kws $comma $k + incr kwl [string length $k] + if {$kwl > 12} { + set kwl 0 + set comma ",
    " + } else { + set comma ", " + } + } + tr Keywords: $kws + } + puts "
    " + } + if {!$matched} { + puts "

    No existing TIPs matched your\ + search criteria.

    " + } + } + proc stest {flagname state} { + upvar 1 flag flagAry d headers + expr {$flagAry($flagname) && ![string compare $headers(State) $state]} + } + proc longidx2 {locus pat1 pat2 dateLimit daterel order} { + array set flag { + titles 0 + keywords 0 + abstracts 0 + bodies 0 + authors 0 + created 0 + nofinal 0 + nodraft 0 + project 0 + noreject 0 + } + foreach feature $locus {set flag($feature) 1} + set matched {} + if {[string match 8.0* [info tclversion]]} { + regsub -all {[^a-zA-Z0-9]} $pat1 {\\&} RE1 + regsub -all {[^a-zA-Z0-9]} $pat2 {\\&} RE2 + } else { + set RE1 ***=$pat1 + set RE2 ***=$pat2 + } + if {$flag(created)} { + regsub -- (.+)-(.+)-(.+) $dateLimit {\2 \1, \3} dateLimit + set dateLimit [clock scan $dateLimit -gmt 1] + } + foreachTIP d { + # skip some TIPs if requested + if { + [stest nofinal Final] || [stest nodraft Draft] || + [stest noreject Rejected] || [stest noreject Withdrawn] || + ($flag(project) && [string compare $d(Type) Project]) + } then { + continue + } + # Perform main search + if { + [string length $pat1] && + (!$flag(titles) || ![regexp $RE1 "TIP #$d(TIP): $d(Title)"]) && + (!$flag(keywords) || [info exist d(Keywords)] && [lsearch -regexp $d(Keywords) $RE1]<0) && + (!$flag(abstracts) || ![regexp $RE1 $d(Abstract)]) && + (!$flag(bodies) || [lsearch -regexp $d(Body) $RE1]<0) + } then { + continue + } + # Perform author filtering + if {$flag(authors) && [lsearch -regexp $d(Author) $RE2]<0} { + continue + } + # Perform date filtering + if {$flag(created)} { + switch -- $daterel { + on { + if {$d(Created) != $dateLimit} {continue} + } + before { + if {$d(Created) >= $dateLimit} {continue} + } + after { + if {$d(Created) <= $dateLimit} {continue} + } + default { + continue + } + } + } + lappend matched [list $d($order) [array get d]] + } + if {[array exists d]} { + unset d + } + foreach match [lsort -dictionary -index 0 $matched] { + array set d [lindex $match 1] + puts "

    " + + puts -nonewline "" + puts "TIP #$d(TIP):\ + $d(Title)" + puts "
    $d(Version)
    " + ordinary $d(Abstract) + puts "
    " + + puts "
    " + set at "Author:" + global AuthorRE + foreach a $d(Author) { + regexp "^$AuthorRE" $a -> name mail + tr $at [xformauthor $name $mail $d(TIP)] + #tr $at "$name" + set at "" + } + tr Type: $d(Type) + if {[info exist d(Tcl-Version)]} { + tr "Tcl Version:" $d(Tcl-Version) + } + tr State: $d(State) + tr Vote: $d(Vote) + tr Created: [clock format $d(Created) -format "%d %b %Y" -gmt 1] + tr "Posting History:" [join [split $d(Post-History) ","] "
    "] + if {[info exist d(Discussions-To)]} { + set dtlink {} + foreach dt [split $d(Discussions-To) ,] { + regsub "^(mailto|news):" $dt "" dtnproto + lappend dtlink "$dtnproto" + } + tr "Discussions To:" [join $dtlink "
    "] + } + if {[info exist d(Obsoletes)]} { + tr Obsoletes: "TIP #$d(Obsoletes)" + } + if {[info exist d(Obsoleted-By)]} { + tr "Obsoleted By:" "TIP #$d(Obsoleted-By)" + } + if {[info exist d(Vote-By)]} { + if {$d(Vote-By) > [clock seconds]} { + tr Vote: [clock format $d(Vote-By) -gmt 1 \ + -format "%d %b %Y, %H:%M GMT"] + } else { + tr Vote-By: [clock format $d(Vote-By) -gmt 1 \ + -format "%d %b %Y, %H:%M GMT (closed)"] + } + } + if {[info exist d(Votes-For)]} { + tr Votes-For: $d(Votes-For) + } + if {[info exist d(Votes-Against)]} { + tr Votes-For: $d(Votes-For) + } + if {[info exist d(Votes-Abstained)]} { + tr Votes-For: $d(Votes-For) + } + if {[info exist d(Keywords)]} { + set kws {} + set kwl 0 + set comma "" + foreach k $d(Keywords) { + append kws $comma $k + incr kwl [string length $k] + if {$kwl > 12} { + set kwl 0 + set comma ",
    " + } else { + set comma ", " + } + } + tr Keywords: $kws + } + puts "
    " + unset d + } + if {![llength $matched]} { + puts "

    No existing TIPs matched your\ + search criteria.

    " + } + } + + # Helpers to generate 'medium' style indices + proc medcell {size colour style link content {hover ""}} { + set content [quoteLiteral $content] + if {[string length $style]} { + set content <$style>$content + } + set title "" + if {[string length $hover]} { + set title "title=\"$hover\"" + } + return "$content" + } + proc medhdr {link content} { + puts "$content" + } + proc getStyle {type vote state} { + upvar d d split split + switch -glob -- $type { + Info* {set ty i;set style i} + Project {set ty j;set style ""} + Process {set ty c;set style b} + } + set ty2 $ty + if {$split} {set style ""} + switch $vote { + "In progress" { + set bgcol yellow + append ty2 v + } + Pending { + set bgcol white + append ty2 p + } + Done - "No voting" { + set bgcol "" + append ty2 f + } + } + switch $state { + Draft { + if {[info exist d(Obsoleted-By)]} { + set col #606060 + } elseif {$bgcol != "yellow"} { + set col #006000 + } else { + set col black + } + append ty2 . + } + Withdrawn - Rejected { + set bgcol #c0c0c0 + if {[info exist d(Obsoleted-By)]} { + set col #606060 + } else { + set col #404040 + } + append ty2 x + } + Accepted { + set bgcol #CCCCFF + if {[info exist d(Obsoleted-By)]} { + set col #606060 + } else { + set col black + } + append ty2 ! + } + Deferred { + set bgcol #CCFFCC + set col black + append ty2 d + } + Final { + if {[info exist d(Obsoleted-By)]} { + set col #606060 + } else { + set col black + } + append ty2 F + } + default { + if {[info exist d(Obsoleted-By)]} { + set col #606060 + } else { + set col black + } + append ty2 - + } + } + if {[info exist d(Obsoleted-By)]} { + append ty2 o + } + list $ty $col $bgcol $style $ty2 + } + proc medidx {tpat order url} { + set split [expr \ + {![string compare $order none] && ![string compare $tpat *]}] + set HR "
    " + + set url [string trimleft $url /]?type=$tpat,sort + medhdr $url[expr {$order=="0"?"=-":"="}]0 "Series ID" + medhdr $url[expr {$order=="1"?"=-":"="}]1 "Type" + medhdr $url[expr {$order=="2"?"=-":"="}]2 "State" + medhdr $url[expr {$order=="3"?"=-":"="}]3 "Title" + puts -nonewline "$HR" + array set rows {} + if {[regexp {^-([0-3])} $order -> digit]} { + set rev -decreasing + set order $digit + } else { + set rev -increasing + } + foreachTIP d { + if {![string match $tpat [string tolower $d(Type)]]} { + continue + } + foreach {ty col bgcol style ty2} \ + [getStyle $d(Type) $d(Vote) $d(State)] {} + + set hover "" + switch -glob -- $ty2 { + *v* {set hover "A vote is in progress on this TIP"} + j*d* {set hover "This TIP has been deferred"} + j*!* {set hover "This TIP awaits implementation"} + j*.* {set hover "This TIP is still in discussion"} + j*F* {set hover "This TIP is in the core, version $d(Tcl-Version)"} + *x* {set hover "This TIP was not adopted by the TCT"} + *o {set hover "This TIP is obsolete"} + } + + set cols {} + lappend cols $d(TIP) \ + [medcell 2 $col $style $d(TIP).html TIP\ #$d(TIP) $hover] + if {![string compare $d(Type) Project]} { + lappend cols $d(Type) \ + [medcell 1 $col $style $d(TIP).html \ + $d(Type)\xa0($d(Tcl-Version)) $hover] + } else { + lappend cols $d(Type) \ + [medcell 1 $col $style $d(TIP).html $d(Type) $hover] + } + lappend cols $d(State) \ + [medcell 1 $col $style $d(TIP).html $d(State) $hover] + lappend cols $d(Title) \ + [medcell 2 $col $style $d(TIP).html $d(Title) $hover] + lappend cols $bgcol {} + lappend rows(all) $cols + lappend rows($ty) $cols + } + + if {!$split} { + set index 0 + catch { + if {$order>=0 && $order<4} { + set index [expr {int($order*2)}] + } + } + foreach row [lsort -dictionary $rev -index $index $rows(all)] { + set bgcol [lindex $row 8] + if {[string length $bgcol]} { + puts "" + } else { + puts "" + } + foreach {index col} $row { + if {[string length $col]} { + puts $col + } + } + puts -nonewline "" + } + puts -nonewline $HR + return + } + + set sep "" + foreach {ty Name} { + c "Process TIPs" + i "Informational TIPs" + j "Project TIPs" + } { + if {![info exist rows($ty)]} {continue} + puts "$Name" + foreach row $rows($ty) { + set bgcol [lindex $row 8] + if {[string length $bgcol]} { + puts "" + } else { + puts "" + } + foreach {index col} $row { + if {[string length $col]} { + puts $col + } + } + puts -nonewline "" + } + puts -nonewline $HR + } + puts "" + puts "

    Search archive\ + for TIPs containing:
    \ +  Advanced Search

    " + puts "
    " + } + variable shortIndexLastAnchor 0 + proc index {kind {errorKind soft} {tpat *}} { + global AuthorRE + closecontext + # Kinds of indices? short, medium, long, bibtex + switch -- $kind { + short { + variable shortIndexLastAnchor + foreachTIPreverse d { + if {![string match $tpat [string tolower $d(Type)]]} { + continue + } + puts -nonewline "

    name + puts "title=\"Author: $name" + puts "Type: $d(Type)" + puts "State: $d(State)" + puts -nonewline "Voting: $d(Vote)\"" + puts -nonewline ">TIP #$d(TIP):" + switch -glob -- $d(State),$d(Vote) { + "*,In progress" { + puts -nonewline " Voting" + } + "Draft,No voting" { + # No special tag + } + Accepted,* { + puts -nonewline " Accepted" + } + Draft,* { + puts -nonewline " Draft" + } + Rejected,* { + puts -nonewline " Rejected" + } + Withdrawn,* { + puts -nonewline " Withdrawn" + } + } + puts "
    $d(Title)

    " + } + } + medium { + global orderingColumn what + puts "
    " + medidx $tpat $orderingColumn $what + puts "
    " + } + long { + longidx $tpat + } + default { + if {[string compare $errorKind soft]} { + return -code error "Index style $kind not supported" + } + puts "

    Index\ + style \"$kind\" not yet supported!

    " + } + } + } + + if {![llength [info command ::imwidth::getImageWidth]]} { + source $SRCDIR/imwidth.tcl + } + proc image {bodytext} { + global ImageRE DOCDIR contenttypes + closecontext + set caption {} + set w 0 + regexp $ImageRE [string trim $bodytext] -> url caption + if {[regexp {^[-_a-zA-Z0-9]+$} $url]} { + foreach {ext type} [array get contenttypes] { + # Order is random, but shouldn't matter. + if { + [string match image/* $type] && + [file exists [set f [file join $DOCDIR $url$ext]]] + } then { + set w [::imwidth::getImageWidth $f] + set url $url$ext + break + } + } + } + set imgtag [format {img src="%s"} $url] + if {[string length $caption]} { + append imgtag " alt=\"[quoteLiteral $caption]\"" + } + if {$w > 450} { + set imgtag "a href=\"$url\"><$imgtag width=\"85%\"> 0} { + append imgtag " width=\"$w\"" + } + puts "

    <$imgtag>

    " + } + + proc fmtauthor {author tip} { + global AuthorRE + regexp "^$AuthorRE$" $author -> name email + return [xformauthor $name $email $tip 1] + } + + proc generateTIPHeader {head {revisioninfo {}}} { + # generate HTML header + array set h $head + global BASETARG BASEURL CSSURL ICONURL + puts "" + if {[string length $revisioninfo]} { + set title "TIP #$h(TIP) Version $revisioninfo: $h(Title)" + } else { + set title "TIP #$h(TIP): $h(Title)" + } + puts "$title" + puts "" + puts "" + puts "" + if {[info exist h(Keywords)]} { + set keywords [join $h(Keywords) ", "] + puts "" + } + puts "" + puts "" + puts "" + if {[string length $revisioninfo]} { + puts "

    $title

    This is not\ + necessarily the current version of this\ + TIP.

    " + } else { + puts "

    $title

    " + } + variable thisTIPnumber $h(TIP) + puts "" + puts "" + puts "" + switch [llength $h(Author)] { + 0 {} + 1 { + set a [fmtauthor [lindex $h(Author) 0] $h(TIP)] + puts "" + } + default { + puts "" + } + } + foreach tag {State Type Tcl-Version Vote Votes-For Votes-Against Votes-Abstained} { + if {[info exist h($tag)] && [string length $h($tag)]} { + puts "${tag}:" + } + } + set t [clock format $h(Created) -format {%A, %d %B %Y} -gmt 1] + puts "" + if {[info exist h(Vote-By)]} { + set t [clock format $h(Vote-By) -gmt 1 \ + -format {%A, %d %B %Y, %H:%M GMT}] + if {$h(Vote-By) > [clock seconds]} { + puts "" + } else { + puts "" + } + } + foreach tag {Post-History} { + if {[string length $h($tag)]} { + puts "${tag}:" + } + } + if { + [info exist h(Discussions-To)] && + [string length $h(Discussions-To)] + } { + foreach dt [split $h(Discussions-To) ,] { + set dt [string trim $dt] + puts -nonewline "Discussions To:" + } else { + puts "$dt" + } + } + } + foreach tag {Obsoletes Obsoleted-By} { + if {[info exist h($tag)] && [string length $h($tag)]} { + puts "" + } + } + if {[info exist h(Keywords)]} { + puts "" + } + puts "
    TIP:$h(TIP)
    Title:$h(Title)
    Version:$h(Version)
    Author:$a
    Authors:" + foreach a $h(Author) {puts "[fmtauthor $a $h(TIP)]
    "} + puts "
    $h($tag)
    Created:$t
    Vote-By:$t
    Vote-By:$t\ + (Vote Closed)
    $h($tag)
    " + global URLRE + if {[regexp ^$URLRE$ $dt]} { + puts "$dt
    ${tag}:TIP #$h($tag)
    Keywords:[join $h(Keywords) {, }]
    " + } + + proc clickelem {url mouseover text} { + upvar elems elems + regsub -all { } $text {\ } text + lappend elems [format "\[%s\]" $url $mouseover $mouseover $text] + } + proc generateDocument {head body {revision ""}} { + array set h $head + generateTIPHeader $head $revision + + # generate HTML body + foreach par $body { + eval [intuitParagraphKind $par] + } + + # generate HTML footer + separator + global FOOTERTEXT FEATURE CVSWEBURL EDITURLBASE + global TCLLOGOURL TCLLOGOX TCLLOGOY + if {[string length $revision]} { + puts "

    \"PoweredThis is not\ + necessarily the current version of this\ + TIP.

    $FOOTERTEXT
    " + return + } + set elems {} + clickelem 1.html "Go to the index page" Index + if {$FEATURE(CVSWEB)} { + clickelem [format $CVSWEBURL $h(TIP)] \ + "Go to document history" History + } + if {($FEATURE(EDIT) || $FEATURE(EDIT_URL_HTML))&& ![notEditable? h]} { + clickelem $EDITURLBASE/$h(TIP) "Edit this TIP" Edit + } + clickelem $h(TIP).html "Format as HTML" "HTML Format" + clickelem $h(TIP).tip "View source" "Source Format" + clickelem $h(TIP).tex "Format as LaTeX" "LaTeX Format" + clickelem $h(TIP).txt "Format as plain text" "Text Format" + clickelem $h(TIP).xml "Format as XML" "XML Format" + clickelem $h(TIP).ms "Format as *roff with -ms macro package" \ + "*roff Format (experimental)" + clickelem $h(TIP).rtf "Format as rich text" \ + "RTF Format (experimental)" + puts "

    \"Powered[join $elems]

    " + puts "
    $FOOTERTEXT
    " + } +} ADDED lib/render/ms.tcl Index: lib/render/ms.tcl ================================================================== --- /dev/null +++ lib/render/ms.tcl @@ -0,0 +1,218 @@ +namespace eval tipms { + proc putspar {string} { + global TIPURLRE BASEURL ShortTIPRE ISSUEBASE ISSUEURLRE + regsub -all {'''(('?[^'])+)'''} $string "\x82\\fB\\1\\fR" string + regsub -all {''(('?[^'\x82])+)''} $string "\\fI\\1\\fR" string + regsub -all $TIPURLRE $string "$BASEURL\\1.html" string + regsub -all $ISSUEURLRE $string "$ISSUEBASE\\1" string + regsub -all {\[\[} $string \x80 string + regsub -all {\]\]} $string \x81 string + regsub -all $ShortTIPRE $string "\[TIP #\\1\]" string + regsub -all \x80 $string \[ string + regsub -all \x81 $string \] string + regsub -all \x82 $string {} string + if {[string match .* $string]} { + puts "\\$string" + } else { + puts $string + } + } + + variable counters {} + proc manageListCounters {level num} { + variable counters + if { + [regexp {^1$} $num] && + $level < [llength $counters] && + [lindex $counters $level] != "*" + } then { + set num [lindex $counters $level] + incr num + } + set counters [lrange [linsert $counters $level $num] 0 $level] + return [lindex $counters end] + } + variable incontext -1 + + proc setcontext {{level -1}} { + variable incontext + for {} {$incontext > $level} {incr incontext -1} {puts .RE} + for {} {$incontext < $level} {incr incontext} {puts .RS} + } + proc endcount {} { + variable counters {} + } + + proc section {title {level 1}} { + setcontext + endcount + puts ".NH $level\n\\fB$title\\fR" + } + proc ordinary {string} { + endcount + continuation -1 $string + } + proc item {tag level body} { + incr level -1 + setcontext $level + puts ".IP $tag" + putspar $body + } + proc bulleting {level body} { + manageListCounters $level * + set s [lindex {bu sq hy} [expr {$level % 3}]] + item "\\ \\($s" $level $body + } + proc enumeration {tag level body} { + set tag [manageListCounters $level $tag] + item "\" ${tag}: \"" $level $body + } + proc description {tag level body} { + manageListCounters $level * + item "\"$tag \"" $level $body + } + proc continuation {level body} { + variable incontext + if {$level != -1 && $incontext<0} { + puts .QP + } else { + if {$level > 0} { + setcontext [expr {$level-1}] + } else { + setcontext $level + } + puts .LP + } + putspar $body + } + proc separator {} { + endcount + setcontext + puts .Hl + } + proc verbatim {lines} { + puts .LD + foreach string $lines { + regsub -all "\[ \t\]" $string {\\&} string + if {[string match .* $string]} { + puts "\\$string" + } else { + puts $string + } + } + puts .DE + } + proc index {kind {errorKind soft} {tpat *}} { + endcount + setcontext + switch -- $kind { + medium { + puts ".TS H\ncenter;\nlb|lb|lb|lb." + puts "Series ID\tType\tState\tTitle\n_\n.TH" + puts ".T&\nl|l|l|lw(3.5i)." + foreachTIP d { + if {[string compare $d(Vote) "In progress"]} { + set v $d(State) + } else { + set v Voting + } + set t $d(Type) + if {[string match Info* $t]} {set t Info.} + puts "TIP #$d(TIP)\t$t\t$v\t\\fI$d(Title)\\fR" + } + puts ".TE" + } + short { + puts ".CD\n.TS\nc l.\n\\fBSeries ID\\fR\t\\fBTitle\\fR" + foreachTIP d { + puts "TIP #$d(TIP)\t$d(Title)" + } + puts ".TE\n.DE" + } + default { + if {[string compare $errorKind soft]} { + return -code error "Index style $kind not supported" + } + set msg "*Index style \"$kind\" not yet supported*" + regsub -all . $msg * stars + puts ".CD\n$stars\n$msg\n$stars\n.DE" + } + } + } + proc image {bodytext} { + endcount + setcontext + global ImageRE + puts .CD + if { + [regexp $ImageRE $bodytext -> url caption] && + [regexp {^[-_a-zA-Z0-9]+$} $url] + } then { + global DOCDIR + set fn [file join $DOCDIR $url.txt] + if {[file isfile $fn] && [file readable $fn]} { + set f [open $fn r] + set lines [split [read -nonewline $f] "\n"] + close $f + foreach line $lines { + puts " $line" + } + puts "" + putspar $caption + } + } elseif {[info exist url] && [info exist caption]} { + puts "" + putspar $caption + } else { + puts "<<$bodytext>>" + } + puts .DE + } + proc generateDocument {head body} { + array set h $head + puts {.\" t +.\" Note that this file *must* be preprocessed with tbl before being +.\" passed to *roff. Fail to do this and things will break... +.de Hl +.br +\l'\\n(.lu-\\n(.iu' +.sp +..} + puts ".TL\nTIP #$h(TIP): $h(Title)\n" + puts ".AU\n[join $h(Author) ,\n]" + puts [clock format $h(Created) -format ".DA \"%d %b %Y\"" -gmt 1] + switch $h(State) { + Accepted - Final - Active { + puts ".AI\nTcl Core Team" + } + Draft { + puts ".AI\n.BX DRAFT" + } + } + puts .AB + putspar [lindex [intuitParagraphKind [lindex $body 1]] 1] + puts .AE + puts ".TS\nbox;\nlb | lb.\nTIP #$h(TIP):\t$h(Title)" + puts "_\n.T&\nl | l." + foreach hdr { + Type State Vote Version Tcl-Version Post-History Discussions-To + Obsoletes Obsoleted-By Keywords Votes-For Votes-Against + Votes-Abstained + } { + if {![info exist h($hdr)]} {continue} + puts "${hdr}:\t$h($hdr)" + } + if {[info exist h(Vote-By)]} { + puts [clock format $h(Vote-By) -gmt 1 \ + -format "Vote-By:\t%d %b %Y, %H:%M GMT"] + } + puts .TE + puts .1C + foreach par [lrange $body 2 end] { + eval [intuitParagraphKind $par] + } + puts ".SH\nColophon\n.LP" + global FOOTERTEXT + puts $FOOTERTEXT + } +} ADDED lib/render/rtf.tcl Index: lib/render/rtf.tcl ================================================================== --- /dev/null +++ lib/render/rtf.tcl @@ -0,0 +1,210 @@ +# TIP to RTF generator v0.1 +# No indices nor images supported +# No TIP headers generation +# Juan C. Gil +namespace eval tiprtf { + variable FONT + array set FONT {SANS 0 SERIF 1 TYPE 2 SYMB 3} + + # The indent amount + variable indent 426 + + # Enumeration counters + variable counters [list] + + # Generates the RTF header + proc RTF-documentHeader {tipnum title} { + puts "\{\\rtf1\\ansi\\ansicpg1252\\deff0\\deflang3082\ + \n{\\fonttbl\n{\\f0\\fswiss\\fcharset0\ + Arial;}\n{\\f1\\froman\\fprq2\\fcharset0 Times New\ + Roman;}\n{\\f2\\fmodern\\fprq1\\fcharset0 Courier\ + New;}\n{\\f3\\fnil\\fcharset2 Symbol;}\n}\ + \n\\viewkind4\\uc1\ + \n\\paperw11907\\paperh16840\\margl1797\\margr1797\n" + RTF-paragraph SANS 32 200 0 0 "\\b TIP #${tipnum}: $title\\b0" + separator + } + + # Generates the RTF header + proc RTF-documentTrailer {} { + puts \} + } + + # Generates a section heading + proc section {title {level 1}} { + variable counters [list] + if {$level > 4} {set level 4} + set size [lindex {32 24 20 16 14} $level] + RTF-paragraph SANS $size [expr {int($size*12)}] 0 0 $title + } + + # Generates an RTF paragraph heading + # f = font + # fs = font size + # sb = space between paragraphs + # li = left indent + # fi = first line indent + proc RTF-paragraph-heading {f fs sb li fi} { + variable FONT + puts [format {\pard\f%s\fs%s\sb%s\li%s\fi%s} \ + $FONT($f) $fs $sb $li $fi] + } + # Generates an RTF paragraph with leading and trailing matter + # All args as above, plus: + # str = body of the paragraph + proc RTF-paragraph {f fs sb li fi str} { + RTF-paragraph-heading $f $fs $sb $li $fi + puts "$str\\par\n" + } + + if {[catch {string repeat _ 77}]} { + proc strrep {str count} { + regsub -all " " [format %*s $count ""] $str var + set var + } + } else { + interp alias {} [namespace current]::strrep {} string repeat + } + # Generates a separator + proc separator {} { + variable counters [list] + RTF-paragraph SERIF 20 0 0 0 [strrep _ 77] + } + + # Generates a verbatim paragraph + proc verbatim {lines} { + variable indent + set sb 120 + foreach line $lines { + RTF-paragraph TYPE 20 $sb $indent 0 $line + set sb 0 + } + } + + # Generates a paragraph + proc paragraph {body {level 0} {bullet 0} {outdent 0} {usesTabs 0}} { + variable indent + + # NEED PROCESSING FOR BACKSLASH CHARACTERS AND OTHER ESCAPES! + + # Bold and emphasis + regsub -all {'''(('?[^'])+)'''} $body "\x81\\b \\1\\b0 " body + regsub -all {''(('?[^'\x81])+)''} $body "\\i \\1\\i0 " body + regsub -all \x81 $body "" body + + set li [expr {$level * $indent}] + if {$outdent} { + incr li $indent + RTF-paragraph-heading SERIF 20 120 $li -$indent + } else { + RTF-paragraph-heading SERIF 20 120 $li 0 + } + if {$usesTabs} { + set tab $indent + foreach i {1 2 3 4 5} { + puts -nonewline [format {\tx%s} $tab] + incr tab $indent + } + puts {} + } + if {$bullet} { + puts {{\*\pn\pnlvlblt\pnf3\pnindent0{\pntxtb\'B7}}} + } + puts "$body\\par\n" + } + + # Manages the enumeration counters + proc manage-counters {level number} { + variable counters + if { + ![string compare $number 1] && + $level < [llength $counters] && + [string compare [lindex $counters $level] *] + } then { + set number [lindex $counters $level] + incr number + } + set counters [lrange [linsert $counters $level $number] 0 $level] + return [lindex $counters end] + } + + # Generates an enumerated item + proc enumeration {tag level body} { + paragraph "[manage-counters $level $tag].\\tab $body" $level 0 1 1 + } + + # Generates a description item + proc description {tag level body} { + manage-counters $level * + paragraph "\\b $tag\\b0\\tab $body" $level 0 1 1 + } + + # Generates a bulleted item + proc bulleting {level body} { + manage-counters $level * + paragraph $body $level 1 1 + } + + # Generates a continuation paragraph + proc continuation {level body} { + paragraph $body $level + } + + # Generates an ordinary paragraph + proc ordinary {body} { + variable counters [list] + paragraph $body + } + + proc index {args} { + RTF-paragraph SANS 10 120 0 0 "indexes not implemented" + } + proc image {args} { + RTF-paragraph SANS 10 120 0 0 "images not implemented" + } + + proc RTF-tablerow {part1 part2 {font SERIF}} { + variable FONT + RTF-paragraph SERIF 11 0 0 0 "${part1}:\\tab{\\f$FONT($font) $part2}" + } + + # Generates the RTF document + proc generateDocument {head body} { + array set header $head + + # Generate the RTF header + RTF-documentHeader $header(TIP) $header(Title) + + # Generate the content header table + puts "\{\\tx1440" + RTF-tablerow TIP $header(TIP) + RTF-tablerow Title $header(Title) + RTF-tablerow Version $header(Version) TYPE + RTF-tablerow Authors [join $header(Author) "\\line\\tab "] + RTF-tablerow State $header(State) + RTF-tablerow Type $header(Type) + if {[info exist header(Tcl-Version)]} { + RTF-tablerow Tcl-Version $header(Tcl-Version) + } + RTF-tablerow Vote $header(Vote) + RTF-tablerow Created [clock format $header(Created)] + if {[info exist header(Keywords)]} { + RTF-tablerow Keywords [join $header(Keywords) ", "] + } + puts "\}" + + # Loop over paragraphs + foreach par $body { + eval [intuitParagraphKind $par] + } + + # Generate the content trailer + global FOOTERTEXT + separator + section Colophon + ordinary $FOOTERTEXT + + # Generate the RTF trailer + RTF-documentTrailer + } +} ADDED lib/render/tex.tcl Index: lib/render/tex.tcl ================================================================== --- /dev/null +++ lib/render/tex.tcl @@ -0,0 +1,623 @@ +source $SRCDIR/imwidth.tcl +source $SRCDIR/epstopdf.tcl +namespace eval tiptex { + variable idxnum 0 + variable citations + array set citations {} + proc quote {body {dbs 0}} { + if {$dbs} { + regsub -all {\\} $body {\(\backslash\)} body + regsub -all {([{}])} $body {\\\1} body + } + regsub -all {LaTeX } $body {LaTeX\\ } body + regsub -all {LaTeX[^a-zA-Z]} $body {\\&} body + regsub -all < $body {\tiplangle{}} body + regsub -all > $body {\tiprangle{}} body + regsub -all {\|} $body {\tipbar{}} body + #regsub -all {[<>|]} $body {\(&\)} body + regsub -all {\^} $body {\textasciicircum{}} body + regsub -all {([%&_$#])} $body {\\\1} body + regsub -all ~ $body {\~{}} body + regsub -all { - } $body " \x80 " body + regsub -all {([0-9])--([0-9])} $body "\\1\x81\\2" body + while {[regsub -- -- $body "-{}-" body]} {} + regsub -all "\x80" $body --- body + regsub -all "\x81" $body -- body + # TeX does not use a standard encoding. Damn! + regsub -all "\xa9" $body {(c)} body + regsub -all "\xe1" $body {\'{a}} body + regsub -all "\xe9" $body {\'{e}} body + regsub -all "\xef" $body {\"{\i}} body + regsub -all "\xf1" $body {\~{n}} body + regsub -all "\xf3" $body {\'{o}} body + regsub -all "\xf4" $body {\^{o}} body + return $body + } + proc paragraph {body} { + global EmailRE URLRE TIPURLRE ShortTIPRE BASEURL ISSUEBASE ISSUEURLRE + variable mode + regsub -all $EmailRE $body "\x82\\1\x83" body + regsub -all $TIPURLRE $body "$BASEURL\\1.tex" body + regsub -all $ISSUEURLRE $body "$ISSUEBASE\\1" body + regsub -all {\\} $body {\(\backslash\)} body + regsub -all {([{}])} $body {\\\1} body + regsub -all {'''(('?[^'])+)'''} $body "\x89\\textbf{\\1}" body + regsub -all {''(('?[^'\x89])+)''} $body "\\textit{\\1}" body + regsub -all \x89 $body {} body + regsub -all {''+} $body {\(&\)} body + regsub -all "\"(\[^\"\]+)\"" $body "``\\1''" body + + set txt $body + set body {} + while {[regexp -indices $URLRE $txt match]} { + foreach {f t} $match {} + set pre [string range $txt 0 [expr {$f-1}]] + set url [string range $txt $f $t] + set post [string range $txt [expr {$t+1}] end] + regsub -all ~ $url "\x84" url + regsub -all & $url "\x85" url + regsub -all _ $url "\x86" url + append body $pre "\\url{" $url "}" + set txt $post + } + append body $txt + + regsub -all {\[\[} $body \x87 body + regsub -all {\]\]} $body \x88 body + switch $mode { + one { + regsub -all $ShortTIPRE $body "\\cite{tip\\1}" body + } + all { + regsub -all $ShortTIPRE $body \ + "\\hyperlink{tip\\1}{TIP ##\\1}" body + } + default { + error "unknown mode \"$mode\"" + } + } + + set body [quote $body] + while {[regsub "(\x82\[^\x82\x83\]*)\\\\_(\[^\x82\x83\]*\x83)" $body \ + {\1_\2} body]} { + # Underscores must not be quoted inside a \tipmail command + } + regsub -all "\x82(\[^ @\x82\x83]+)@(\[^ @\x82\x83]+)\x83" $body \ + "\\tipmail{\\1}{\\2}" body + regsub -all "\x84" $body ~ body + regsub -all "\x85" $body \\& body + regsub -all "\x86" $body _ body + regsub -all "\x87" $body \[ body + regsub -all "\x88" $body \] body + puts $body + # now, we need to find the citations made... + variable citations + while {[regexp -indices {\\cite{tip([0-9]+)}} $body -> idxpair]} { + foreach {x y} $idxpair {} + set cite [string range $body $x $y] + set body [string range $body $y end] + set citations($cite) 1 + } + } + + variable contexts {} + proc closecontext {} { + variable contexts + foreach c $contexts { + puts "\\end{$c}" + } + puts "" + set contexts {} + } + proc closetolevel {level} { + variable contexts + while {[llength $contexts] > $level} { + set c [lindex $contexts 0] + set contexts [lrange $contexts 1 end] + puts "\\end{$c}" + } + } + proc startcontext {type} { + variable contexts + set contexts [linsert $contexts 0 $type] + puts "\\begin{$type}" + } + proc changecontext {type} { + variable contexts + set cold [lindex $contexts 0] + if {[string compare $type $cold]} { + puts "\\end{$cold}\n\\begin{$type}" + set contexts [lreplace $contexts 0 0 $type] + } + } + proc liststart {level type} { + closetolevel [incr level] + variable contexts + if {[llength $contexts] == $level} { + changecontext $type + } else { + startcontext $type + } + } + + proc bulleting {level body} { + liststart $level itemize + puts "\\item{}" + paragraph $body + } + proc description {tag level body} { + liststart $level description + puts "\\item\[[quote $tag 1]\]" + paragraph $body + } + proc enumeration {tag level body} { + liststart $level enumerate + if {$tag != 1} { + incr tag -1 + set d 0 + variable contexts + foreach c $contexts {if {![string compare $c enumerate]} {incr d}} + switch $d { + 1 {puts "\\setcounter{enumi}{$tag}"} + 2 {puts "\\setcounter{enumii}{$tag}"} + 3 {puts "\\setcounter{enumiii}{$tag}"} + 4 {puts "\\setcounter{enumiv}{$tag}"} + } + } + puts "\\item{}" + paragraph $body + } + proc continuation {level body} { + variable contexts + if {[llength $contexts] == 0 && $level == 1} { + puts "\n\\begin{quote}" + paragraph $body + puts "\\end{quote}" + return + } + closetolevel $level + puts "" + paragraph $body + } + + proc section {title {level 1}} { + variable idxnum + closecontext + set cmd {} + for {set i 1} {$i<$level} {incr i} {append cmd sub} + puts "\\[append cmd section]{[quote $title 1]}" + } + proc image {bodytext} { + global ImageRE DOCDIR BASEURL + variable idxnum + regexp $ImageRE [string trim $bodytext] -> url caption + closecontext + puts "\\begin{figure}\[htbp\]\\begin{center}\\leavevmode" + if { + [regexp {^[-_a-zA-Z0-9]+$} $url] && + [file exists [set fn [file join $DOCDIR $url.eps]]] + } then { + puts "\\tipimage{$url}{[::imwidth::getImageWidth $fn]pt}" + } else { + puts "\\fbox{\\tiny\\url{$url}}" + } + puts "\\caption{[quote $caption 1]}" + puts "\\end{center}\\end{figure}" + } + proc ordinary {body} { + closecontext + paragraph $body + } + proc separator {} { + closecontext + puts "\\vspace{3ex}\\hrule\\vspace{1.5ex}" + } + proc verbatim {lines} { + puts "\\begingroup\\small\\begin{verbatim}" + foreach line $lines { + # Ugh! LaTeX chokes on formfeed characters in verbatim, + # which tend to be common in quoted patches to the core... + regsub -all { } $line ^L line + puts $line + } + puts "\\end{verbatim}\n\\endgroup" + } + proc shorten {length string} { + if {$length+2 >= [string length $string]} {return $string} + return [string range $string 0 $length]. + } + proc index {kind {errorKind soft}} { + closecontext + switch -- $kind { + short { + foreachTIP d { + set num "TIP #$d(TIP):" + switch $d(State) { + Draft - Rejected - Withdrawn { + set state "(\\emph{$d(State)})" + } + default {set state ""} + } + puts "[quote $num] $state" + paragraph $d(Title) + puts "" + } + } + medium { + puts "\\begin{center}\\begin{supertabular}{c|ll|p{2.5in}}" + puts "\\textbf{TIP ID}&\\textbf{Type}&\\textbf{State}&\ + \\textbf{Title}\\\\\\hline" + foreachTIP d { + puts -nonewline "\\small TIP \\#$d(TIP)&\\small\ + [shorten 5 $d(Type)]&\\small\ + [shorten 4 $d(State)]&\\small " + paragraph $d(Title) + puts -nonewline "\\\\" + } + puts "\\end{supertabular}\\end{center}" + } + long { + puts "\\begin{center}\\begin{supertabular}{|lp{3.3in}|}\\hline" + set docsep "" + foreachTIP d { + puts $docsep + puts -nonewline "\\textbf{TIP \\#$d(TIP)}:&" + puts "\\textbf{[quote $d(Title)]}\\\\" + puts "Version:&\\tipversion$d(Version)\\\\" + + regsub -all "\t" $d(Author) " " authorNotab + if {[llength $d(Author)] == 1} { + puts -nonewline "Author:&" + paragraph [lindex $authorNotab 0] + puts "\\\\" + } else { + puts -nonewline "Authors:&" + paragraph [lindex $authorNotab 0] + foreach a [lrange $authorNotab 1 end] { + puts -nonewline "\\par " + paragraph $a + } + puts "\\\\" + } + + puts "State:&$d(State)\\\\Type:&$d(Type)\\\\" + if {[info exist d(Tcl-Version)]} { + puts "Tcl Version:&$d(Tcl-Version)\\\\" + } + puts "Vote:&$d(Vote)\\\\" + puts [clock format $d(Created) -gmt 1 \ + -format "Created:&%d %B %Y\\\\"] + puts "Posting History:&" + set ph "" + foreach event [split $d(Post-History) ","] { + puts $ph[quote [string trim $event]] + set ph "\\par " + } + puts "\\\\" + if {[info exist d(Discussions-To)]} { + regsub -all {,} $d(Discussions-To) {, } dt + puts "Discussions To:&[quote $dt]\\\\" + } + if {[info exist d(Obsoletes)]} { + puts "Obsoletes:&TIP \\#$d(Obsoletes)\\\\" + } + if {[info exist d(Obsoleted-By)]} { + puts "Obsoleted By:&TIP \\#$d(Obsoleted-By)\\\\" + } + if {[info exist d(Vote-By)]} { + if {$d(Vote-By) > [clock seconds]} { + set inf "" + } else { + set inf " (closed)" + } + puts [clock format $d(Vote-By) -gmt 1 \ + -format "Vote By:&%d %B %Y, %H:%M GMT$inf\\\\"] + } + if {[info exist d(Votes-For)]} { + puts "Votes For:&$d(Votes-For)\\\\" + } + if {[info exist d(Votes-Against)]} { + puts "Votes Against:&$d(Votes-Against)\\\\" + } + if {[info exist d(Votes-Abstained)]} { + puts "Votes Abstained:&$d(Votes-Abstained)\\\\" + } + if {[info exist d(Keywords)]} { + puts "Keywords:&[quote [join $d(Keywords) {, }]]\\\\" + } + puts "&\\\\Abstract:&" + paragraph $d(Abstract) + set docsep "\\\\\\hline\\hline" + } + puts "\\\\\\hline\\end{supertabular}\\end{center}" + } + default { + puts "\\fbox{\\textbf{Index ``$kind'' not yet supported}}" + } + } + } + + proc generateDocumentHeader {headerArrayName {emptyPage 1} {targ {}}} { + upvar $headerArrayName h + + puts "\\begin{center}\\begin{tabularx}{\\linewidth}{|r@{: }X|}\\hline" + if {[string length $targ]} { + puts [format {\hypertarget{%s}{\textbf{%s}}&\textbf{%s}\\\hline} \ + $targ [quote "TIP #$h(TIP)" 1] [quote $h(Title) 1]] + } else { + puts [format "\\textbf{%s}&\\textbf{%s}\\\\\\hline" \ + [quote "TIP #$h(TIP)" 1] [quote $h(Title) 1]] + } + puts [quote Author 1]& + set sep "" + foreach a $h(Author) { + puts $sep; set sep "\\par" + paragraph $a + } + puts "\\\\" + set d [clock format $h(Created) -gmt 1 -format %d] + switch $d { + 01 - 21 - 31 { set ord st } + 02 - 22 { set ord nd } + 03 - 23 { set ord rd } + default { set ord th } + } + set d [string trimleft $d 0] + puts [clock format $h(Created) -gmt 1 -format \ + "Created&%A, \\(\\text{$d}^{\\text{$ord}}\\) %B %Y\\\\"] + puts "Type&$h(Type)\\\\" + if {[info exist h(Tcl-Version)]} { + regsub a $h(Tcl-Version) \\alpha h(Tcl-Version) + regsub b $h(Tcl-Version) \\beta h(Tcl-Version) + puts "Tcl Version&\\($h(Tcl-Version)\\)\\\\" + unset h(Tcl-Version) + } + puts "State&$h(State)\\\\" + puts "Vote&$h(Vote)\\\\" + puts "Version&\\tipversion$h(Version)\\\\" + if {[info exist h(Keywords)]} { + puts "Keywords&[quote [join $h(Keywords) {, }] 1]\\\\" + unset h(Keywords) + } + if {[info exist h(Vote-By)]} { + if {$h(Vote-By) > [clock seconds]} { + set inf "" + } else { + set inf " (closed)" + } + puts [clock format $h(Vote-By) -gmt 1 \ + -format "Vote By:&%d %B %Y, %H:%M GMT$inf\\\\"] + unset h(Vote-By) + } + + unset h(TIP) h(Title) h(Author) h(Created) + unset h(Version) h(Type) h(State) h(Vote) + # Do any fields I've forgotten! + foreach {key val} [array get h] { + regsub -all -- {-} $key { } key + puts [format {%s&%s\\} [quote $key 1] [quote $val 1]] + } + puts "\\hline\\end{tabularx}\\end{center}" + if {$emptyPage} {puts "\\thispagestyle{empty}\\pagestyle{empty}"} + } + + proc generateDocRefs {{reflevel section}} { + global PUBLISHURL DOCDIR + variable citations + if {[array size citations]} { + puts "\\begin{thebibliography}{TIP \\#[array size citations]}" + puts "\\addcontentsline{toc}{$reflevel}{References}" + foreach cite [lsort -dictionary [array names citations]] { + array set dtl [getTIPDetails [file join $DOCDIR $cite.tip]] + puts "\\bibitem\[TIP \\#$cite\]{tip$cite}" + foreach a $dtl(Author) { + regsub {<.*} $a {} a + puts "[quote [string trim $a] 1]," + } + puts "\\emph{[quote $dtl(Title) 1]}," + puts "on-line at \\url{$PUBLISHURL/$cite.html}" + unset dtl + } + puts "\\end{thebibliography}" + } + } + + # The static part of the header, used to define things that would + # otherwise be extremely backslash-heavy. + variable tipdefs { + \urlstyle{sf} + \setlength{\parskip}{1ex} + \setlength{\parindent}{0pt} + \def\tipversion$#1${\texttt{\$#1\$}} + \def\tiplangle#1{\ensuremath{<}} + \def\tiprangle#1{\ensuremath{>}} + \def\tipbar#1{\ensuremath{|}} + \def\tipmail#1#2{\(\langle\){\small\expandafter\url{#1@#2}}\(\rangle\)} + \ifx\pdfoutput\undefined + \newcommand{\tipimage}[2]{% + \typeout{Make sure you download #1.eps}\ifthenelse{% + \lengthtest{0.8\textwidth>#2}\and\lengthtest{0pt<#2}}{% + \includegraphics{#1.eps}}{% + \includegraphics[width=0.8\textwidth]{#1.eps}}} + \newcommand{\tipxref}[1]{} + \newcommand{\tipxrefend}{} + \else + \newcommand{\tipimage}[2]{% + \typeout{Make sure you create #1.pdf}\ifthenelse{% + \lengthtest{0.8\textwidth>#2}\and\lengthtest{0pt<#2}}{% + \includegraphics{#1.pdf}}{% + \includegraphics[width=0.8\textwidth]{#1.pdf}}} + \pdfcatalog{/PageMode /UseOutlines} + \newcommand{\tipxref}[1]{\pdfannotlink % + attr {/C [0.5 0.5 1.0] /Border [0 0 1]} % + goto name {#1}} + \newcommand{\tipxrefend}{\pdfendlink} + \fi + \newenvironment{tipabstract}{% + \begin{abstract}}{\end{abstract}} + } + + proc generateLaTeXPreamble {title author {date {}} {class article}} { + global env + variable tipdefs + set ltxopts {} + set ltxpkg {} + if {[info exist env(LATEXOPTS)]} { + set ltxopts [split $env(LATEXOPTS) ,] + } + #set ltxopts [linsert $ltxopts 0 dvips] + if {[info exist env(LATEXPACKAGES)]} { + set ltxpkg [split $env(LATEXPACKAGES) ,] + } + set ltxpkg [linsert $ltxpkg 0 \ + amsmath graphicx supertabular hyperref tabularx ifthen] + puts "\\documentclass\[[join $ltxopts ,]\]{$class}" + puts "\\usepackage{[join $ltxpkg ,]}" + puts "\\title{[quote $title 1]}" + if {[string length $date]} { + puts "\\date{[quote $date 1]}" + } + puts "\\author{[quote $author 1]}" + regsub -all "\n\[ \t]+" [string trim $tipdefs] "\n" strippedTD + regsub -all "%\n" $strippedTD {} strippedTD + puts $strippedTD + puts "\\begin{document}\\maketitle" + } + + proc generateDocument {head body} { + global FOOTERTEXT + variable mode one + array set h $head + + set authors {} + set sep "" + foreach a $h(Author) { + regsub -all "\[ \t\]*<.*" $a "" a + append authors "$sep$a" + set sep ", " + } + + generateLaTeXPreamble "TIP #$h(TIP): $h(Title)" $authors \ + [clock format $h(Created) -gmt 1 -format "%B %d, %Y"] + + generateDocumentHeader h + puts "\\begin{tipabstract}" + eval [intuitParagraphKind [lindex $body 1]] + puts "\\end{tipabstract}" + + puts "\\tableofcontents\\setcounter{page}{0}\\clearpage\\pagestyle{plain}" + foreach par [lrange $body 2 end] { + eval [intuitParagraphKind $par] + } + section "Colophon" + ordinary ''$FOOTERTEXT'' + generateDocRefs + puts "\\end{document}" + } + + variable imageURLCache + array set imageURLCache {} + proc getImageURLs {tipNumber} { + global DOCDIR + variable imageURLCache + if {[info exist imageURLCache($tipNumber)]} { + return $imageURLCache($tipNumber) + } + set images {} + if {$tipNumber == "all"} { + foreach tip [getTIPFilenames] { + array set dtl [getTIPDetails $tip] + foreach par $dtl(Body) { + set cmd [intuitParagraphKind $par] + if {[lindex $cmd 0] == "image"} { + lappend images [lindex $cmd 1] + } + } + } + } else { + array set dtl [getTIPDetails [file join $DOCDIR $tipNumber.tip]] + foreach par $dtl(Body) { + set cmd [intuitParagraphKind $par] + if {[lindex $cmd 0] == "image"} { + lappend images [lindex $cmd 1] + } + } + } + set imageURLCache($tipNumber) $images + } + proc linkEPSImagesForDocument {tipNumber targetDir} { + foreach url [getImageURLs $tipNumber] { + if { + [regexp {^[-_a-zA-Z0-9]+$} $url] && + [file exists [set src [file join $DOCDIR $url.eps]]] + } + if {![file exists [set dst [file join $targetDir $url.eps]]]} { + exec ln -s $src $dst + } + } + } + proc makePDFImagesForDocument {tipNumber targetDir} { + set urls [getImageURLs $tipNumber] + linkEPSImagesForDocument $tipNumber $targetDir + foreach url $urls { + if { + ![regexp {^[-_a-zA-Z0-9]+$} $url] || + ![file exists [set src [file join $targetDir $url.eps]]] + } { + continue + } + set dst [file join $targetDir $url.pdf] + if {[file exists $dst] && [file mtime $dst]>[file mtime $src]} { + continue + } + epstopdf::epstopdf $src $dst + } + } + + proc generateWholeArchive {} { + variable mode all + variable idxnum + variable citations + set tips [getTIPFilenames] + set t1 [file rootname [file tail [lindex $tips 0]]] + set tn [file rootname [file tail [lindex $tips end]]] + generateLaTeXPreamble \ + [format {Tcl Improvement Proposals: TIPs %d--%d} $t1 $tn] \ + {The Tcl Community} {} report + puts "\\renewcommand{\\bibname}{References}" + puts "\\renewcommand{\\chaptername}{TIP \\#}" + puts "\\addtocounter{chapter}{-1}" + puts "\\tableofcontents\\listoffigures" + + foreach tip $tips { + ::puts -nonewline stderr \[ + set pars [splitIntoParagraphs [getTIPFileContents $tip]] + array set h [verifyTIPheader \ + [splitRFC822Header [lindex $pars 0]]] + set kinds {} + foreach par [lrange $pars 2 end] { + lappend kinds [intuitParagraphKind $par] + } + + ::puts -nonewline stderr $h(TIP) + puts "\\chapter{[quote $h(Title) 1]}" + generateDocumentHeader h 0 tip$h(TIP) + puts "\\section{Abstract}" + eval [lindex $kinds 0] + puts "\\clearpage" + unset h + foreach par [lrange $kinds 1 end] { eval $par } + closecontext + ::puts -nonewline stderr "\] " + } + ::puts stderr "" + if {[array size citations]} { + puts "\\clearpage" + set idx [incr idxnum] + puts "\\ifx\\pdfoutput\\undefined\\relax\\else\\pdfdest\ + num $idx xyz\\pdfoutline goto num $idx {References}\\fi" + generateDocRefs chapter + } + puts "\\end{document}" + } +} ADDED lib/render/tk.tcl Index: lib/render/tk.tcl ================================================================== --- /dev/null +++ lib/render/tk.tcl @@ -0,0 +1,182 @@ +namespace eval tipview { + proc section {title {level 1}} { + variable w + $w insert end $title\n section$level + } + proc formattedInsert {string tag} { + variable w + regsub -all {'''(('?[^'])+)'''} $string \x81\\1\x81 string + regsub -all {''(('?[^'])+)''} $string \x80\\1\x80 string + set idx [$w index end] + $w insert end $s\n $tag + while {1} { + set idx [$w search -regexp "\x80|\x81" $idx end] + if {$idx eq ""} break + set c [$w get $idx] + set idx2 [$w search -exact $c $idx+1c end] + switch [$w get $idx] { + \x80 {$w tag add ${tag}_i $idx $idx2} + \x81 {$w tag add ${tag}_b $idx $idx2} + } + $w delete $idx2 + $w delete $idx + } + } + proc ordinary {string} { + formattedInsert $string plain + } + proc bulleting {level body} { + formattedInsert *\t$body list[expr {$level+1}] + } + proc description {tag level body} { + formattedInsert ${tag}:\t$body list[expr {$level+1}] + } + proc enumeration {tag level body} { + formattedInsert $tag.\t$body list[expr {$level+1}] + } + proc continuation {level body} { + formattedInsert $body cont$level + } + proc separator {} { + variable w + variable sep + if {![info exist sep]} { + set wide [expr {[winfo reqwidth $w]-25}] + set sep [::image create photo -width $wide -height 1] + $sep put black -to 0 0 $wide 1 + } + $w image create end -image $sep -padx 5 -pady 5 + $w insert end \n + } + proc verbatim {lines} { + variable w + $w insert end \n[join $lines \n]\n\n verbatim + } + proc index {kind} { + variable w + $w insert end "Index $kind not supported by this renderer\n" + } + proc image {bodytext} { + variable w + if {[regexp {^([^./ ]+) +(.*)} $bodytext -> f caption]} { + global DOCDIR + set f [file join $DOCDIR $f.gif] + if {[file exist $f]} { + variable img + if {![info exist img($f)]} { + set wide [expr {[winfo reqwidth $w]-25}] + set img($f) [::image create photo -file $f] + while {[::image width $img($f)] > $wide} { + set i [::image create photo] + $i copy $img($f) -subsample 2 2 + ::image delete $img($f) + set img($f) $i + } + } + $w image create end -image $img($f) -padx 5 -pady 5 + $w insert end \n {} $caption caption \n + return + } + } + $w insert end "Image $bodytext not supported by this renderer\n" + } + + proc generateTIPHeader {hName w} { + upvar 1 $hName h + set l $w.top + set hi [expr {[array size h]-1+[llength $h(Author)]}] + pack [text $l -height $hi -wrap word -font {Times -14}] \ + -side top -fill x -expand 1 + $l tag configure key -font {Times -14 bold} + set wide 1 + set font {Times -14 bold} + foreach n [array names h] { + set nw [font measure $font ${n}:] + if {$nw>$wide} {set wide $nw} + } + incr wide 4 + $l configure -tabs $wide + $l tag configure head -lmargin1 0 -lmargin2 $wide + array set done {TIP . Title . Author . Created .} + $l insert end TIP: {head key} \t$h(TIP)\n head + $l insert end Title: {head key} \t$h(Title)\n head + $l insert end Created: {head key} [clock format $h(Created) -gmt 1 \ + -format "\t%A %d %B %Y\n"] head + $l insert end Authors: {head key} "\t[join $h(Author) \n\t]\n" head + foreach n [lsort [array names h]] { + if {[info exist done($n)]} {continue} + $l insert end ${n}: {head key} \t$h($n)\n head + } + $l delete end-1c + $l configure -state disabled + } + proc viewTIP {tipnumber} { + global DOCDIR + set file [file join $DOCDIR $tipnumber.tip] + set data [getTIPFileContents $file] + set pars [splitIntoParagraphs $data] + set heads [verifyTIPheader [splitRFC822Header [lindex $pars 0]]] + set par1 [intuitParagraphKind [lindex $pars 1]] + array set h $heads + if {[string compare $par1 {section Abstract 1}]} { + return -code error "TIP $h(TIP) must start with abstract..." + } + + set t .t$h(TIP) + catch {destroy $t} + toplevel $t + wm title $t "TIP #$h(TIP): $h(Title)" + wm iconname $t "TIP #$h(TIP)" + + generateTIPHeader h $t + + variable w $t.bot + pack [text $w -wrap word] \ + -side top -fill both -expand 1 + + $w tag configure section1 -font {Helvetica -18 bold} \ + -lmargin1 1m -rmargin 1m -spacing1 1m -spacing3 1m + $w tag configure section2 -font {Helvetica -14 bold} \ + -lmargin1 1m -rmargin 1m -spacing1 1m -spacing3 1m + $w tag configure section3 -font {Helvetica -12 bold} \ + -lmargin1 1m -rmargin 1m -spacing1 1m -spacing3 1m + $w tag configure verbatim -font {Courier 10} + $w tag configure plain -font {Times 10} \ + -lmargin1 2m -lmargin2 2m -rmargin 2m -spacing3 1m + $w tag configure plain_i -font {Times 10 italic} + $w tag configure plain_b -font {Times 10 bold} + for {set i 1} {$i<5} {incr i} { + $w tag configure list$i -font {Times 10} \ + -lmargin1 [expr {$i*4+1}]m -lmargin2 [expr {$i*4+5}]m \ + -rmargin 2m -spacing3 1m -tabs 5m + $w tag configure list${i}_i -font {Times 10 italic} + $w tag configure list${i}_b -font {Times 10 bold} + $w tag configure cont$i -font {Times 10} \ + -lmargin1 [expr {$i*4+5}]m -lmargin2 [expr {$i*4+5}]m \ + -rmargin 2m -spacing3 1m + $w tag configure cont${i}_i -font {Times 10 italic} + $w tag configure cont${i}_b -font {Times 10 bold} + } + + # generate HTML body + foreach par [lrange $pars 1 end] { + eval [intuitParagraphKind $par] + } + } +} + +if {![string compare [file join [pwd] $::argv0] [file join [pwd] [info script]]]} { + # test mode! + set SRCDIR [file dirname [file join [pwd] [info script]]] + source $SRCDIR/config.tcl + source $SRCDIR/parse.tcl + + package require Tk + pack [listbox .l -width 5 -yscroll {.s set}] \ + [scrollbar .s -orient vertical -command {.l yview}] \ + -side left -expand 1 -fill both + foreachTIP t { + .l insert end $t(TIP) + } + bind .l {tipview::viewTIP [.l get @%x,%y]} +} ADDED lib/render/txt.tcl Index: lib/render/txt.tcl ================================================================== --- /dev/null +++ lib/render/txt.tcl @@ -0,0 +1,380 @@ +namespace eval tiptxt { + proc fmtPar {firsthead nexthead body} { + puts "" + set str "" + set body "$firsthead $body" + # Apply standard transformations here... + global URLRE TIPURLRE ShortTIPRE BASEURL ISSUEBASE ISSUEURLRE + regsub -all $TIPURLRE $body "$BASEURL\\1.txt" body + regsub -all $ISSUEURLRE $body "$ISSUEBASE\\1" body + regsub -all $URLRE $body "" body + regsub -all {\[\[} $body \x80 body + regsub -all {\]\]} $body \x81 body + regsub -all $ShortTIPRE $body "\[TIP #\\1\]" body + regsub -all ''' $body {*} body + regsub -all '' $body {/} body + regsub -all \x80 $body \[ body + regsub -all \x81 $body \] body + foreach word [split $body] { + if {[string length $str$word] > 72} { + puts $str + set str "$nexthead " + } + append str $word " " + } + puts $str + } + + variable counters {} + proc manageListCounters {level num} { + variable counters + if { + [regexp {^1$} $num] && + $level < [llength $counters] && + [lindex $counters $level] != "*" + } then { + set num [lindex $counters $level] + incr num + } + set counters [lrange [linsert $counters $level $num] 0 $level] + return [lindex $counters end] + } + proc setupIndents {level {msg ""}} { + format "%*s" [expr {$level>=0?($level+1)*7-1:0}] $msg + } + + proc bulleting {level body} { + manageListCounters $level * + set ind [setupIndents $level] + regsub {.$} $ind * ind1 + fmtPar $ind1 $ind $body + } + proc description {tag level body} { + set tag " ${tag}:" + set body [string trim $body] + manageListCounters $level * + set ind1 [setupIndents [expr {$level-1}]] + set ind [setupIndents $level] + set tagspace [expr {[string length $ind]-[string length $ind1]}] + if {$tagspace*2 < [string length $tag]} { + puts -nonewline \n$ind1$tag + fmtPar $ind $ind $body + } elseif {$tagspace < [string length $tag]} { + fmtPar $ind1$tag $ind $body + } else { + fmtPar [format %s%-*s $ind1 $tagspace $tag] $ind $body + } + } + proc enumeration {tag level body} { + set indt [setupIndents $level [manageListCounters $level $tag].] + set inds [setupIndents $level] + fmtPar $indt $inds $body + } + proc continuation {level string} { + set indent [setupIndents [expr {$level-1}]] + fmtPar $indent $indent $string + } + proc ordinary {string} { + variable counters {} + continuation -1 $string + } + + proc section {title {level 1}} { + variable counters {} + switch $level { + 1 { + regsub -all . $title = uline + puts "\n [string toupper $title] \n=$uline=" + } + 2 { + regsub -all . $title - uline + puts "\n [string toupper $title] \n-$uline-" + } + 3 { + puts "\n [string toupper $title] " + } + default { + regsub -all " " $title _ title + puts "\n_$title_" + } + } + } + proc separator {} { + variable counters {} + puts -nonewline "\n------------------------------" + puts "-------------------------------------------" + } + proc verbatim {lines} { + # It's actually quite awkward, since we have to convert tabs to spaces + puts "" + foreach line $lines { + set bits [split $line \t] + set txt [lindex $bits 0] + foreach bit [lrange $bits 1 end] { + append txt " " + while {[string length $txt] % 8} {append txt " "} + append txt $bit + } + puts " $txt" + } + } + proc centre {lines} { + puts "" + set untabbed {} + set width 0 + foreach line $lines { + set bits [split $line \t] + set txt [lindex $bits 0] + foreach bit [lrange $bits 1 end] { + append txt " " + while {[string length $txt] % 8} {append txt " "} + append txt $bit + } + lappend untabbed $txt + if {[string length $txt]>$width} {set width [string length $txt]} + } + if {$width >= 70} { + foreach line $untabbed { + puts $line + } + } else { + set ind [expr {(72-$width)/2}] + foreach line $untabbed { + puts [format %*s%s $ind "" $line] + } + } + } + proc image {bodytext} { + variable counters {} + global ImageRE + if { + [regexp $ImageRE $bodytext -> url caption] && + [regexp {^[-_a-zA-Z0-9]+$} $url] + } then { + global DOCDIR + set fn [file join $DOCDIR $url.txt] + if {[file isfile $fn] && [file readable $fn]} { + set f [open $fn r] + set lines [split [read -nonewline $f] "\n"] + close $f + centre $lines + centre [list $caption] + return + } + } elseif {[info exist url] && [info exist caption]} { + centre [list "" ] + centre [list $caption] + } else { + centre [list "<<$bodytext>>"] + } + } + proc index {kind {errorKind soft}} { + variable counters {} + switch $kind { + short { + puts "" + foreachTIP d { + puts -nonewline " TIP #$d(TIP):" + switch $d(State) { + Draft - Rejected { + puts -nonewline " ([string index $d(State) 0])" + } + default { + puts -nonewline " " + } + } + puts " $d(Title)" + } + } + medium { + array set w {1 9 2 4 3 5 4 5} + foreachTIP d { + foreach {name col i} { + TIP 1 5 + Type 2 0 + State 3 0 + Title 4 0 + } { + if {[string length $d($name)] > $w($col)+$i} { + set w($col) [expr {[string length $d($name)]+$i}] + } + } + } + puts "" + set format "| %-$w(1)s | %-$w(2)s | %-$w(3)s | %-$w(4)s |" + set sep [format $format " " " " " " " "] + regsub -all " " $sep - sep + regsub -all "\[|\]" $sep + sep + puts $sep + puts [format $format "Series ID" "Type" "State" "Title"] + puts $sep + foreachTIP d { + puts [format $format "TIP #$d(TIP)" \ + $d(Type) $d(State) $d(Title)] + } + puts $sep + } + long { + foreachTIP d { + puts "" + set rows {} + lappend rows "TIP #$d(TIP):" $d(Title) + lappend rows Version: $d(Version) + regsub -all "\t" $d(Author) " " authorNotab + if {[llength $d(Author)] == 1} { + regsub @ [lindex $authorNotab 0] _at_ a + lappend rows Author: $a + } else { + regsub @ [lindex $authorNotab 0] _at_ a + lappend rows Authors: $a + foreach a [lrange $authorNotab 1 end] { + regsub @ $a _at_ a + lappend rows "" $a + } + } + lappend rows State: $d(State) Type: $d(Type) + if {[info exist d(Tcl-Version)]} { + lappend rows "Tcl Version:" $d(Tcl-Version) + } + lappend rows Vote: $d(Vote) + lappend rows Created: [clock format $d(Created) \ + -format "%d %b %Y" -gmt 1] + set ph "Posting History:" + foreach event [split $d(Post-History) ","] { + lappend rows $ph [string trim $event] + set ph "" + } + if {[info exist d(Discussions-To)]} { + set dt [join [split $d(Discussions-To) ,] ", "] + regsub -all -- { +} $dt { } dt + lappend rows "Discussions To:" $dt + } + if {[info exist d(Obsoletes)]} { + lappend rows Obsoletes: "TIP #$d(Obsoletes)" + } + if {[info exist d(Obsoleted-By)]} { + lappend rows "Obsoleted By:" "TIP #$d(Obsoleted-By)" + } + if {[info exist d(Vote-By)]} { + if {$d(Vote-By) > [clock seconds]} { + lappend rows Vote-By: [clock format $d(Vote-By) \ + -format "%d %b %Y, %H:%M GMT" -gmt 1] + } else { + lappend rows Vote-By: [clock format $d(Vote-By) \ + -format "%d %b %Y, %H:%M GMT (closed)" \ + -gmt 1] + } + } + if {[info exist d(Votes-For)]} { + lappend rows "Votes For:" $d(Votes-For) + } + if {[info exist d(Votes-Against)]} { + lappend rows "Votes Against:" $d(Votes-Against) + } + if {[info exist d(Votes-Abstained)]} { + lappend rows "Votes Abstained:" $d(Votes-Abstained) + } + if {[info exist d(Keywords)]} { + lappend rows Keywords: [join $d(Keywords) ", "] + } + set width 1 + foreach {tag ?} $rows { + if {[string length $tag]>$width} { + set width [string length $tag] + } + } + foreach {tag val} $rows { + puts [format "%-*s %s" $width $tag $val] + } + set indent [format "%*s" $width ""] + fmtPar $indent $indent $d(Abstract) + } + } + default { + if {[string compare $errorKind soft]} { + return -code error "Index style $kind not supported" + } + set msg "*Index style \"$kind\" bit yet supported*" + regsub -all . $msg * stars + centre [list $stars $msg $stars] + } + } + } + + proc generateDocument {head body {extra {}}} { + global BASEURL + array set header $head + section "TIP #$header(TIP): $header(Title)" + set lines [list Version: $header(Version)] + set indent 8 + if {[info exist header(Author)]} { + set at Author: + foreach a $header(Author) { + regsub @ $a _at_ a + lappend lines $at $a + set at "" + } + } + foreach h {State Type Tcl-Version Vote} { + if {[info exist header($h)]} { + lappend lines ${h}: $header($h) + if {[string length $h]+1>$indent} { + set indent [expr {[string length $h]+1}] + } + } + } + lappend lines Created: [clock format $header(Created) \ + -format {%A, %d %B %Y} -gmt 1] + if {[string compare [lindex $extra 0] URL]} { + lappend lines URL: $BASEURL$header(TIP).html + } + foreach {key value} $extra {lappend lines ${key}: $value} + if {[info exist header(Discussions-To)]} { + set h Discussions-To: + foreach dt [split $header(Discussions-To) ","] { + lappend lines $h [string trim $dt] + if {[string length $h]>$indent} { + set indent [string length $h] + } + set h "" + } + } + if {[info exist header(Post-History)]} { + lappend lines Post-History: $header(Post-History) + if {[string length Post-History]+1>$indent} { + set indent [expr {[string length Post-History]+1}] + } + } + foreach h {Obsoletes Obsoleted-By} { + if {[info exist header($h)]} { + lappend lines ${h}: "TIP #$header($h)" + if {[string length $h]+1>$indent} { + set indent [expr {[string length $h]+1}] + } + } + } + if {[info exist header(Vote-By)]} { + lappend lines Vote-By: [clock format $header(Vote-By) -gmt 1 \ + -format {%A, %d %B %Y, %H:%M GMT}] + } + foreach h {Votes-For Votes-Against Votes-Abstained} { + if {[info exist header($h)]} { + lappend lines ${h}: $header($h) + if {[string length $h]+1>$indent} { + set indent [expr {[string length $h]+1}] + } + } + } + foreach {key value} $lines { + regsub -all "\t" $value " " value + puts [format " %-*s %s" $indent $key $value] + } + separator + foreach par $body { + eval [intuitParagraphKind $par] + } + separator + global FOOTERTEXT + ordinary $FOOTERTEXT + } +} ADDED lib/render/xml.tcl Index: lib/render/xml.tcl ================================================================== --- /dev/null +++ lib/render/xml.tcl @@ -0,0 +1,345 @@ +source $SRCDIR/base64.tcl +namespace eval tipxml { + variable section + variable sectype + variable secnum -1 + variable title + array set section {} + array set sectype {} + array set title {} + + proc makePCDATA {string} { + regsub -all & $string {\&} string + regsub -all < $string {\<} string + regsub -all > $string {\>} string + regsub -all ' $string {\'} string + regsub -all \" $string {\"} string + return $string + } + proc makeCDATAQ {string} { + # Ho hum, this does the right thing according to the Standard... + return [makePCDATA $string] + #regsub -all \" $string {\\&} string + #return $string + } + + proc makeTextContent {string} { + global URLRE EmailRE ShortTIPRE TIPURLRE ISSUEBASE ISSUEURLRE + set q \x82 + regsub -all $EmailRE $string "" string + regsub -all $ISSUEURLRE $string "$ISSUEBASE\\1" string + regsub -all $URLRE $string "\x80url ref=${q}&${q}/\x81" string + regsub -all {\[\[} $string \x83 string + regsub -all {\]\]} $string \x84 string + regsub -all "\\\[\x80url (\[^\x81\]\x81)\\\]" $string \ + "\x80url style=${q}compact${q} \\1" string + regsub -all {'''(('?[^'])+)'''} $string \ + "\x85\200emph style=${q}bold${q}\x81\\1\x80/emph\x81" string + regsub -all {''(('?[^'\x85])+)''} $string \ + "\200emph style=${q}italic${q}\x81\\1\x80/emph\x81" string + regsub -all $TIPURLRE $string \ + "\x80tipref type=${q}url${q} tip=${q}\\1${q}/\x81" string + regsub -all $ShortTIPRE $string \ + "\x80tipref type=${q}text${q} tip=${q}\\1${q}/\x81" string + regsub -all & $string {\&} string + regsub -all < $string {\<} string + regsub -all > $string {\>} string + regsub -all \" $string {\"} string + regsub -all ' $string {\'} string + regsub -all \x80 $string < string + regsub -all \x81 $string > string + regsub -all \x82 $string \" string + regsub -all \x83 $string \[ string + regsub -all \x84 $string \] string + regsub -all \x85 $string {} string + return $string + } + + variable curlev -1 + variable contexts {} + variable ctext + array set ctext {} + variable encounter + array set encounter {} + proc enterlistcontext {level good bad1 bad2} { + variable curlev + variable contexts + variable ctext + variable encounter + set result 0 + if {$level > $curlev} { + incr curlev + lappend contexts "" + set ctext($curlev) "<$good>" + set encounter($curlev) 0 + set result 1 + } + switch [lindex $contexts end] "" - "" { + set close [lindex $contexts end] + set closei [format "" [string index $close 2]] + append ctext($curlev) $closei $close < $good > + set encounter($curlev) 0 + set contexts [lreplace $contexts end end ""] + set result 1 + } + return $result + } + proc closecontext {{level -1}} { + variable curlev + variable contexts + variable ctext + variable encounter + while {$level < $curlev} { + set txt $ctext($curlev) + unset ctext($curlev) encounter($curlev) + set close [lindex $contexts end] + set closei [format "" [string index $close 2]] + if {[incr curlev -1] >= 0} { + append ctext($curlev) $txt $closei $close + set contexts [lrange $contexts 0 \ + [expr {[llength $contexts]-2}]] + } else { + variable section + variable secnum + lappend section($secnum) "$txt$closei$close" + set contexts [list] + return + } + } + } + + proc continuation {level body} { + variable curlev + variable ctext + variable section + variable secnum + + if {$curlev == -1} { + lappend section($secnum) "[makeTextContent $body]" + return + } + closecontext $level + append ctext($curlev) "" [makeTextContent $body] "" + } + proc bulleting {level body} { + closecontext $level + set flag [enterlistcontext $level itemize enumerate describe] + variable curlev + variable ctext + if {!$flag} { + append ctext($curlev) "" + } + append ctext($curlev) "" + continuation $level $body + } + proc enumeration {tag level body} { + closecontext $level + set flag [enterlistcontext $level enumerate itemize describe] + variable curlev + variable ctext + variable encounter + if {!$flag} { + append ctext($curlev) "" + } + if {$tag == 1} { + set tag [incr encounter($curlev)] + } else { + set encounter($curlev) $tag + } + append ctext($curlev) "" + continuation $level $body + } + proc description {tag level body} { + closecontext $level + set flag [enterlistcontext $level describe enumerate itemize] + variable curlev + variable ctext + if {!$flag} { + append ctext($curlev) "" + } + append ctext($curlev) "" + continuation $level $body + } + proc verbatim {lines} { + variable curlev + set l {} + foreach line $lines { + append l "" [B64encode $line] "" + } + if {$curlev >= 0} { + variable ctext + append ctext($curlev) "" $l "" + } else { + variable section + variable secnum + lappend section($secnum) "$l" + } + } + + ### FIXME! THIS IS *COMPLETELY* WRONG! ### + proc section {secttitle {level 1}} { + closecontext + variable section + variable secnum + variable sectype + variable title + set n [incr secnum] + set title($n) $secttitle + set section($n) {} + set sectype($n) $level + } + proc image {bodytext} { + global ImageRE + closecontext + variable section + variable secnum + set caption {} + regexp $ImageRE [string trim $bodytext] -> url caption + set caption [string trim $caption] + if {[string length $caption]} { + lappend section($secnum) \ + "" + } else { + lappend section($secnum) "" + } + } + proc index {kind} { + closecontext + variable section + variable secnum + lappend section($secnum) "" + } + proc separator {} { + closecontext + variable section + variable secnum + lappend section($secnum) "" + } + proc ordinary {string} { + closecontext + variable section + variable secnum + lappend section($secnum) "[makeTextContent $string]" + } + proc stag {level} { + return [lindex {"" "" sub subsub} $level]section + } + proc generateDocument {head body} { + global AuthorRE BASEURL FOOTERTEXT + array set h $head + puts "" + puts "" + puts "" + puts "\n\n" + puts -nonewline "
    [makePCDATA $h(Title)]" + foreach a $h(Author) { + regexp $AuthorRE $a -> name addr + set name [makePCDATA [string trim $name]] + set addr [makeCDATAQ mailto:$addr] + puts -nonewline "$name" + } + puts -nonewline "[makePCDATA $h(Version)]" + puts -nonewline "" + foreach e $h(Post-History) { + puts -nonewline "[makePCDATA $e]" + } + puts -nonewline "" + eval [clock format $h(Created) -gmt 1 -format {puts -nonewline \ + ""}] + if {[info exist h(Discussions-To)]} { + foreach dt [split $h(Discussions-To) ,] { + puts -nonewline \ + "" + } + } + if {[info exist h(Keywords)]} { + foreach k [split $h(Keywords) ,] { + puts -nonewline \ + "[makePCDATA [string trim $k]]" + } + } + if {[info exist h(Obsoletes)]} { + puts -nonewline "" + } + if {[info exist h(Obsoleted-By)]} { + puts -nonewline "" + } + if { + [info exist h(Vote-By)] || [info exist h(Votes-For)] || + [info exist h(Votes-Against)] || [info exist h(Votes-Abstained)] + } then { + if {[info exist h(Vote-By)]} { + puts -nonewline "" + } else { + puts -nonewline "" + } + if {[info exist h(Votes-For)]} { + puts -nonewline "" + } + if {[info exist h(Votes-Against)]} { + puts -nonewline "" + } + if {[info exist h(Votes-Abstained)]} { + puts -nonewline "" + } + puts -nonewline "" + } + puts "
    " + set abstractCmd [intuitParagraphKind [lindex $body 1]] + puts "[makeTextContent [lindex $abstractCmd 1]]" + puts -nonewline "" + + # Parse the paragraphs + foreach par [lrange $body 2 end] {eval [intuitParagraphKind $par]} + closecontext + # Now need to output the sections... + variable section + variable sectype + variable title + set level 0 + for {set i 0} {$i<[array size section]} {incr i} { + set l $sectype($i) + if {!$level} { + if {$l != 1} { + error "must have section before sub(sub)section" + } + } else { + if {$l-$level == 2} { + error "cannot generate a subsubsection in a section\ + without an intervening subsection" + } + while {$level>=$l} { + puts "" + incr level -1 + } + } + puts "<[stag $l] title=\"[makeCDATAQ $title($i)]\">" + puts [join $section($i) "\n"] + set level $l + } + while {$level>0} { + puts "" + incr level -1 + } + + puts "    " + } +} ADDED lib/utils/base64.tcl Index: lib/utils/base64.tcl ================================================================== --- /dev/null +++ lib/utils/base64.tcl @@ -0,0 +1,16 @@ +proc B64encode {str {len -1}} { + set base64digits \ + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" + binary scan $str B* bits + if {$len < 0} { + set len [string length $bits] + } + set result {} + for {set i 0} {$i<$len} {incr i 6} { + binary scan [binary format B8 \ + 00[string range $bits $i [expr {$i+5}]]0000] c mybits + append result [string index $base64digits $mybits] + } + while {[string length $result] % 4} {append result =} + return $result +} ADDED lib/utils/epstopdf.tcl Index: lib/utils/epstopdf.tcl ================================================================== --- /dev/null +++ lib/utils/epstopdf.tcl @@ -0,0 +1,128 @@ +# Procedure to convert Encapsulated Postscript into PDF by passing +# through ghostscript with the right arguments and with the bounding +# box fixed(!) Based very strongly on the EPSTOPDF script distributed +# with teTeX-1.0 though with some changes (most notably support for +# controlling the level of PDF generated, and redesigned for more +# efficient use as part of a larger work.) + +# This version by Donal K. Fellows, University of Manchester + +# Original by Sebastian Rahtz et al. + +namespace eval epstopdf { + proc correctBbox {llx lly urx ury} { + variable corrected 1 + set width [expr {$urx-$llx}] + set height [expr {$ury-$lly}] + format "%%BoundingBox: 0 0 %d %d\n<< /PageSize \[%s %s\] >>\ + setpagedevice gsave %s %s translate" \ + $width $height $width $height [expr {-$llx}] [expr {-$lly}] + } + proc processHeader {bbstring} { + variable in + variable out + variable isfile + + set spc "\[ \t\]" + set elm {([-0-9e.]+)} + set bboxRE "^%%${bbstring}:$spc*$elm$spc+$elm$spc+$elm$spc+$elm" + set atendRE "^%%${bbstring}:$spc*\\(atend\\)" + while {[gets $in line] >= 0} { + ### end of header + if { + ![string match %* $line] || + [string match %%EndComments* $line] + } then { + puts $out $line + break + } + + ### BoundingBox with values + if {[regexp $bboxRE $line -> llx lly urx ury]} { + puts $out [correctBbox $llx $lly $urx $ury] + break + } + + ### BoundingBox with (atend) + # Can only be processed if seek/tell work (i.e. is ordinary file) + if {[regexp $atendRE $line] && $isfile} { + set pos [tell $in] + # looking for %%BoundingBox + while {[gets $in line] >= 0} { + # skip over included documents + if {[string match %%BeginDocument* $line]} { + while {[gets $in line] >= 0} { + if {[string match %%EndDocument* $line]} {break} + } + } + if {[regexp $bboxRE $line -> llx lly urx ury]} { + puts $out [correctBbox $llx $lly $urx $ury] + break + } + } + + # go back + seek $in $pos + break + } + + # print header line + puts $out $line + } + } + + variable options + array set options { + UseFlateCompression true + CompatibilityLevel 1.2 + } + if {![info exist ::GS]} { + set ::GS gs + } + + namespace export epstopdf + proc epstopdf {infile {outfile ""} {bbstring "BoundingBox"}} { + variable options + variable in + variable out + variable corrected 0 + variable isfile + global GS + + if {![string length $outfile]} { + if {[string compare [file extension $infile] .eps]} { + return -code error "cannot guess output filename" + } + set outfile [file rootname $infile].pdf + } + + set cmd [list $GS -q -sDEVICE=pdfwrite -sOutputFile=$outfile] + foreach key [array names options] { + lappend cmd -d$key=$options($key) + } + lappend cmd - -c quit + + set isfile [file isfile $infile] + set in [open $infile r] + fconfigure $in -translation binary + set out [open |$cmd w] + fconfigure $out -translation binary + + gets $in line + # Trim leading junk which some EPS generators insist on adding + set line [string range $line [string first %! $line] end] + puts $out $line + + if {[string match %* $line]} { + processHeader $bbstring + } + fcopy $in $out + close $in + if {$corrected} { + puts $out grestore + } else { + puts stderr "warning: $bbstring not found in $infile" + } + close $out + } +} ADDED lib/utils/imwidth.tcl Index: lib/utils/imwidth.tcl ================================================================== --- /dev/null +++ lib/utils/imwidth.tcl @@ -0,0 +1,198 @@ +namespace eval ::imwidth { + namespace export getImageWidth + + variable imageWidthCache + array set imageWidthCache {} + proc getImageWidth {imagefile} { + variable imageWidthCache + if {![info exist imageWidthCache($imagefile)]} { + set imageWidthCache($imagefile) 0 + if {[catch { + set imageWidthCache($imagefile) [getImageWidthCore $imagefile] + } msg]} { + puts "DEBUG: imwidth $imagefile -> $msg" + puts ErrorCode=$::errorCode + puts ErrorInfo=$::errorInfo + } + } + return $imageWidthCache($imagefile) + } + proc getImageWidthCore {imagefile} { + global contenttypes + set ext [file extension $imagefile] + if {![string compare $contenttypes($ext) application/postscript]} { + return [epswidth $imagefile] + } + if {![regexp {image/([-a-z]+)} $contenttypes($ext) -> type]} { + return 0 + } + switch $type { + gif { + return [gifsize $imagefile] + } + jpeg { + return [get_jpg_width $imagefile] + } + png { + return [pngsize $imagefile] + } + x-portable-pixmap { + return [PPMwidth $imagefile] + } + } + return 0 + } + + proc PPMwidth {filename} { + set f [open $imagefile r] + gets $f;# Read magic number + while {[gets $f s]+1&&[string length $s]&&[string match #* $s]} {} + close $f + scan $s %d width + return $width + } + + # From the Wiki! + proc gifsize {name} { + set f [open $name r] + fconfigure $f -translation binary + # read GIF signature -- check that this is + # either GIF87a or GIF89a + set sig [read $f 6] + switch $sig { + "GIF87a" - + "GIF89a" { + # do nothing + } + default { + error "$f is not a GIF file" + } + } + + # Read "logical screen size", this is USUALLY the image size + # too. Interpreting the rest of the GIF specification is left + # as an exercise + binary scan [read $f 2] s wid + + return $wid + } + + # From the Wiki! + proc get_jpg_width {filename} { + # open the file + set img [open $filename r+] + # set to binary mode - VERY important + fconfigure $img -translation binary + + # read in first two bytes + binary scan [read $img 2] "H4" byte1 + # check to see if this is a JPEG, all JPEGs start with "ffd8", make + # that SHOULD start with + if {$byte1!="ffd8"} { + close $img + error "$filename is not a valid JPEG file!" + } + + # cool, it's a JPG so let's loop through the whole file until we + # find the next marker. + while { ![eof $img]} { + while {$byte1!="ff"} { + binary scan [read $img 1] "H2" byte1 + } + + # we found the next marker, now read in the marker type byte, + # throw out any extra "ff"'s + while {$byte1=="ff"} { + binary scan [read $img 1] "H2" byte1 + } + + # if this the the "SOF" marker then get the data + if { ($byte1>="c0") && ($byte1<="c3") } { + # it is the right frame. read in a chunk of data + # containing the dimensions. + binary scan [read $img 7] "x3SS" height width + # return the dimensions in a list + close $img + return $width + } else { + # this is not the the "SOF" marker, read in the offset of the + # next marker + binary scan [read $img 2] "S" offset + # the offset includes its own two bytes so we need to subtract + # them + set offset [expr $offset -2] + # move ahead to the next marker + seek $img $offset current + } + + } + # we didn't find an "SOF" marker... + close $img + return 0 + } + + # From the Wiki! + proc pngsize {filename} { + if {[file size $filename] < 33} { + error "File $filename not large enough to contain PNG header" + } + set f [open $filename r] + fconfigure $f -translation binary + + # Read PNG file signature + binary scan [read $f 8] H* sig + if {[string compare $sig 89504e470d0a1a0a]} { + close $f + error "$filename is not a PNG file" + } + + # Read IHDR chunk signature - the length (0x0000000d) never + # changes, and the 49484452 should also always be there as it + # is the string "IHDR"! + binary scan [read $f 8] H* sig + if {[string compare $sig 0000000d49484452]} { + close $f + error "$filename is missing a leading IHDR chunk" + } + + # Read off the size of the image + binary scan [read $f 8] II width height + # Ignore the rest of the data, including the chunk CRC, since I have + # no convenient algorithm to verify it! + + #binary scan [read $f 5] ccccc depth type compression filter interlace + #binary scan [read $f 4] I chunkCRC + + close $f + return $width + } + + proc epswidth {filename} { + set f [open $filename r] + gets $f line + if {![string match %!PS-Adobe* $line]} {close $f; return 0} + if {![regexp EPSF $line]} {close $f; return 0} + set quad {0 0 -1 -1} + set land 0 + while {[string match %* $line]} { + gets $f line + switch -glob -- $line { + "%%BoundingBox: *" { + set quad [string range $line 15 end] + } + "%%Orientation: Landscape" { + set land 1 + } + "%%EndComments" - "%%BeginSetup" { + break + } + } + } + close $f + if {$land} { + return [expr {[lindex $quad 3]-[lindex $quad 1]+1}] + } else { + return [expr {[lindex $quad 2]-[lindex $quad 0]+1}] + } + } +} ADDED lib/utils/md5.tcl Index: lib/utils/md5.tcl ================================================================== --- /dev/null +++ lib/utils/md5.tcl @@ -0,0 +1,347 @@ +################################################## +# +# md5.tcl - MD5 in Tcl +# Author: Don Libes , July 1999 +# Version 1.2.0 +# +# MD5 defined by RFC 1321, "The MD5 Message-Digest Algorithm" +# HMAC defined by RFC 2104, "Keyed-Hashing for Message Authentication" +# +# Most of the comments below come right out of RFC 1321; That's why +# they have such peculiar numbers. In addition, I have retained +# original syntax, bugs in documentation (yes, really), etc. from the +# RFC. All remaining bugs are mine. +# +# HMAC implementation by D. J. Hagberg and +# is based on C code in RFC 2104. +# +# For more info, see: http://expect.nist.gov/md5pure +# +# - Don +################################################## + +### Code speedups by Donal Fellows who may well +### have added some extra bugs of his own... :^) + +namespace eval md5pure { + variable T { + #PADDING + + 0xd76aa478 0xe8c7b756 0x242070db 0xc1bdceee + 0xf57c0faf 0x4787c62a 0xa8304613 0xfd469501 + 0x698098d8 0x8b44f7af 0xffff5bb1 0x895cd7be + 0x6b901122 0xfd987193 0xa679438e 0x49b40821 + + 0xf61e2562 0xc040b340 0x265e5a51 0xe9b6c7aa + 0xd62f105d 0x2441453 0xd8a1e681 0xe7d3fbc8 + 0x21e1cde6 0xc33707d6 0xf4d50d87 0x455a14ed + 0xa9e3e905 0xfcefa3f8 0x676f02d9 0x8d2a4c8a + + 0xfffa3942 0x8771f681 0x6d9d6122 0xfde5380c + 0xa4beea44 0x4bdecfa9 0xf6bb4b60 0xbebfbc70 + 0x289b7ec6 0xeaa127fa 0xd4ef3085 0x4881d05 + 0xd9d4d039 0xe6db99e5 0x1fa27cf8 0xc4ac5665 + + 0xf4292244 0x432aff97 0xab9423a7 0xfc93a039 + 0x655b59c3 0x8f0ccc92 0xffeff47d 0x85845dd1 + 0x6fa87e4f 0xfe2ce6e0 0xa3014314 0x4e0811a1 + 0xf7537e82 0xbd3af235 0x2ad7d2bb 0xeb86d391 + } +} + +# test md5pure +# +# This proc is not necessary during runtime and may be omitted if you +# are simply inserting this file into a production program. +# +proc md5pure::test {} { + foreach {msg expected} { + "" + "d41d8cd98f00b204e9800998ecf8427e" + "a" + "0cc175b9c0f1b6a831c399e269772661" + "abc" + "900150983cd24fb0d6963f7d28e17f72" + "message digest" + "f96b697d7cb7938d525a2f31aaf161d0" + "abcdefghijklmnopqrstuvwxyz" + "c3fcd3d76192e4007dfb496cca67e13b" + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" + "d174ab98d277d9f5a5611c2c9f419d9f" + "12345678901234567890123456789012345678901234567890123456789012345678901234567890" + "57edf4a22be3c955ac49da2e2107b67a" + } { + puts "testing: md5 \"$msg\"" + binary scan [md5 $msg] H32 computed + puts "expected: $expected" + puts "computed: $computed" + if {0 != [string compare $computed $expected]} { + puts "FAILED" + } else { + puts "SUCCEEDED" + } + } +} + +# time md5pure +# +# This proc is not necessary during runtime and may be omitted if you +# are simply inserting this file into a production program. +# +proc md5pure::time {} { + foreach len {10 50 100 500 1000 5000 10000} { + set time [::time {md5 [format %$len.0s ""]} 10] + regexp "\[0-9]*" $time msec + puts "input length $len: [expr {$msec/1000}] milliseconds per interation" + } +} + +proc md5pure::md5 {msg} { + variable T + + # + # 3.1 Step 1. Append Padding Bits + # + + set msgLen [string length $msg] + + set padLen [expr {56 - $msgLen%64}] + if {$msgLen % 64 > 56} { + incr padLen 64 + } + + # pad even if no padding required + if {$padLen == 0} { + incr padLen 64 + } + + # append single 1b followed by 0b's + append msg [binary format "a$padLen" \200] + + # + # 3.2 Step 2. Append Length + # + + # RFC doesn't say whether to use little- or big-endian + # code demonstrates little-endian + # This step limits our input to size 2^32b or 2^24B + append msg [binary format "i1i1" [expr {8*$msgLen}] 0] + + # + # 3.3 Step 3. Initialize MD Buffer + # + + set A [expr 0x67452301] + set B [expr 0xefcdab89] + set C [expr 0x98badcfe] + set D [expr 0x10325476] + + # + # 3.4 Step 4. Process Message in 16-Word Blocks + # + + # process each 16-word block + # RFC doesn't say whether to use little- or big-endian + # code says little-endian + binary scan $msg i* blocks + #set i 0 + #foreach b $blocks { + # set M($i) $b + # incr i + #} + + set blockLen [llength $blocks] + + for {set i 0} {$i < $blockLen} {incr i 16} { + # copy block i into X + set X [lrange $blocks $i [expr {$i+15}]] + #for {set j 0} {$j<16} {incr j} { + # set X($j) $M([expr $i*16+$j]) + #} + + # Save A as AA, B as BB, C as CC, and D as DD. + set AA $A + set BB $B + set CC $C + set DD $D + + # Round 1. + # Let [abcd k s i] denote the operation + # a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s). + # [ABCD 0 7 1] [DABC 1 12 2] [CDAB 2 17 3] [BCDA 3 22 4] + set A [expr {$B + [<<< [expr {$A + (($B&$C)|((~$B)&$D)) + [lindex $X 0] + [lindex $T 1] }] 7]}] + set D [expr {$A + [<<< [expr {$D + (($A&$B)|((~$A)&$C)) + [lindex $X 1] + [lindex $T 2] }] 12]}] + set C [expr {$D + [<<< [expr {$C + (($D&$A)|((~$D)&$B)) + [lindex $X 2] + [lindex $T 3] }] 17]}] + set B [expr {$C + [<<< [expr {$B + (($C&$D)|((~$C)&$A)) + [lindex $X 3] + [lindex $T 4] }] 22]}] + # [ABCD 4 7 5] [DABC 5 12 6] [CDAB 6 17 7] [BCDA 7 22 8] + set A [expr {$B + [<<< [expr {$A + (($B&$C)|((~$B)&$D)) + [lindex $X 4] + [lindex $T 5] }] 7]}] + set D [expr {$A + [<<< [expr {$D + (($A&$B)|((~$A)&$C)) + [lindex $X 5] + [lindex $T 6] }] 12]}] + set C [expr {$D + [<<< [expr {$C + (($D&$A)|((~$D)&$B)) + [lindex $X 6] + [lindex $T 7] }] 17]}] + set B [expr {$C + [<<< [expr {$B + (($C&$D)|((~$C)&$A)) + [lindex $X 7] + [lindex $T 8] }] 22]}] + # [ABCD 8 7 9] [DABC 9 12 10] [CDAB 10 17 11] [BCDA 11 22 12] + set A [expr {$B + [<<< [expr {$A + (($B&$C)|((~$B)&$D)) + [lindex $X 8] + [lindex $T 9] }] 7]}] + set D [expr {$A + [<<< [expr {$D + (($A&$B)|((~$A)&$C)) + [lindex $X 9] + [lindex $T 10]}] 12]}] + set C [expr {$D + [<<< [expr {$C + (($D&$A)|((~$D)&$B)) + [lindex $X 10] + [lindex $T 11]}] 17]}] + set B [expr {$C + [<<< [expr {$B + (($C&$D)|((~$C)&$A)) + [lindex $X 11] + [lindex $T 12]}] 22]}] + # [ABCD 12 7 13] [DABC 13 12 14] [CDAB 14 17 15] [BCDA 15 22 16] + set A [expr {$B + [<<< [expr {$A + (($B&$C)|((~$B)&$D)) + [lindex $X 12] + [lindex $T 13]}] 7]}] + set D [expr {$A + [<<< [expr {$D + (($A&$B)|((~$A)&$C)) + [lindex $X 13] + [lindex $T 14]}] 12]}] + set C [expr {$D + [<<< [expr {$C + (($D&$A)|((~$D)&$B)) + [lindex $X 14] + [lindex $T 15]}] 17]}] + set B [expr {$C + [<<< [expr {$B + (($C&$D)|((~$C)&$A)) + [lindex $X 15] + [lindex $T 16]}] 22]}] + + # Round 2. + # Let [abcd k s i] denote the operation + # a = b + ((a + G(b,c,d) + X[k] + T[i]) <<< s). + # Do the following 16 operations. + # [ABCD 1 5 17] [DABC 6 9 18] [CDAB 11 14 19] [BCDA 0 20 20] + set A [expr {$B + [<<< [expr {$A + (($B&$D)|($C&(~$D))) + [lindex $X 1] + [lindex $T 17]}] 5]}] + set D [expr {$A + [<<< [expr {$D + (($A&$C)|($B&(~$C))) + [lindex $X 6] + [lindex $T 18]}] 9]}] + set C [expr {$D + [<<< [expr {$C + (($D&$B)|($A&(~$B))) + [lindex $X 11] + [lindex $T 19]}] 14]}] + set B [expr {$C + [<<< [expr {$B + (($C&$A)|($D&(~$A))) + [lindex $X 0] + [lindex $T 20]}] 20]}] + # [ABCD 5 5 21] [DABC 10 9 22] [CDAB 15 14 23] [BCDA 4 20 24] + set A [expr {$B + [<<< [expr {$A + (($B&$D)|($C&(~$D))) + [lindex $X 5] + [lindex $T 21]}] 5]}] + set D [expr {$A + [<<< [expr {$D + (($A&$C)|($B&(~$C))) + [lindex $X 10] + [lindex $T 22]}] 9]}] + set C [expr {$D + [<<< [expr {$C + (($D&$B)|($A&(~$B))) + [lindex $X 15] + [lindex $T 23]}] 14]}] + set B [expr {$C + [<<< [expr {$B + (($C&$A)|($D&(~$A))) + [lindex $X 4] + [lindex $T 24]}] 20]}] + # [ABCD 9 5 25] [DABC 14 9 26] [CDAB 3 14 27] [BCDA 8 20 28] + set A [expr {$B + [<<< [expr {$A + (($B&$D)|($C&(~$D))) + [lindex $X 9] + [lindex $T 25]}] 5]}] + set D [expr {$A + [<<< [expr {$D + (($A&$C)|($B&(~$C))) + [lindex $X 14] + [lindex $T 26]}] 9]}] + set C [expr {$D + [<<< [expr {$C + (($D&$B)|($A&(~$B))) + [lindex $X 3] + [lindex $T 27]}] 14]}] + set B [expr {$C + [<<< [expr {$B + (($C&$A)|($D&(~$A))) + [lindex $X 8] + [lindex $T 28]}] 20]}] + # [ABCD 13 5 29] [DABC 2 9 30] [CDAB 7 14 31] [BCDA 12 20 32] + set A [expr {$B + [<<< [expr {$A + (($B&$D)|($C&(~$D))) + [lindex $X 13] + [lindex $T 29]}] 5]}] + set D [expr {$A + [<<< [expr {$D + (($A&$C)|($B&(~$C))) + [lindex $X 2] + [lindex $T 30]}] 9]}] + set C [expr {$D + [<<< [expr {$C + (($D&$B)|($A&(~$B))) + [lindex $X 7] + [lindex $T 31]}] 14]}] + set B [expr {$C + [<<< [expr {$B + (($C&$A)|($D&(~$A))) + [lindex $X 12] + [lindex $T 32]}] 20]}] + + # Round 3. + # Let [abcd k s t] [sic] denote the operation + # a = b + ((a + H(b,c,d) + X[k] + T[i]) <<< s). + # Do the following 16 operations. + # [ABCD 5 4 33] [DABC 8 11 34] [CDAB 11 16 35] [BCDA 14 23 36] + set A [expr {$B + [<<< [expr {$A + ($B^$C^$D) + [lindex $X 5] + [lindex $T 33]}] 4]}] + set D [expr {$A + [<<< [expr {$D + ($A^$B^$C) + [lindex $X 8] + [lindex $T 34]}] 11]}] + set C [expr {$D + [<<< [expr {$C + ($D^$A^$B) + [lindex $X 11] + [lindex $T 35]}] 16]}] + set B [expr {$C + [<<< [expr {$B + ($C^$D^$A) + [lindex $X 14] + [lindex $T 36]}] 23]}] + # [ABCD 1 4 37] [DABC 4 11 38] [CDAB 7 16 39] [BCDA 10 23 40] + set A [expr {$B + [<<< [expr {$A + ($B^$C^$D) + [lindex $X 1] + [lindex $T 37]}] 4]}] + set D [expr {$A + [<<< [expr {$D + ($A^$B^$C) + [lindex $X 4] + [lindex $T 38]}] 11]}] + set C [expr {$D + [<<< [expr {$C + ($D^$A^$B) + [lindex $X 7] + [lindex $T 39]}] 16]}] + set B [expr {$C + [<<< [expr {$B + ($C^$D^$A) + [lindex $X 10] + [lindex $T 40]}] 23]}] + # [ABCD 13 4 41] [DABC 0 11 42] [CDAB 3 16 43] [BCDA 6 23 44] + set A [expr {$B + [<<< [expr {$A + ($B^$C^$D) + [lindex $X 13] + [lindex $T 41]}] 4]}] + set D [expr {$A + [<<< [expr {$D + ($A^$B^$C) + [lindex $X 0] + [lindex $T 42]}] 11]}] + set C [expr {$D + [<<< [expr {$C + ($D^$A^$B) + [lindex $X 3] + [lindex $T 43]}] 16]}] + set B [expr {$C + [<<< [expr {$B + ($C^$D^$A) + [lindex $X 6] + [lindex $T 44]}] 23]}] + # [ABCD 9 4 45] [DABC 12 11 46] [CDAB 15 16 47] [BCDA 2 23 48] + set A [expr {$B + [<<< [expr {$A + ($B^$C^$D) + [lindex $X 9] + [lindex $T 45]}] 4]}] + set D [expr {$A + [<<< [expr {$D + ($A^$B^$C) + [lindex $X 12] + [lindex $T 46]}] 11]}] + set C [expr {$D + [<<< [expr {$C + ($D^$A^$B) + [lindex $X 15] + [lindex $T 47]}] 16]}] + set B [expr {$C + [<<< [expr {$B + ($C^$D^$A) + [lindex $X 2] + [lindex $T 48]}] 23]}] + + # Round 4. + # Let [abcd k s t] [sic] denote the operation + # a = b + ((a + I(b,c,d) + X[k] + T[i]) <<< s). + # Do the following 16 operations. + # [ABCD 0 6 49] [DABC 7 10 50] [CDAB 14 15 51] [BCDA 5 21 52] + set A [expr {$B + [<<< [expr {$A + ($C^($B|~$D)) + [lindex $X 0] + [lindex $T 49]}] 6]}] + set D [expr {$A + [<<< [expr {$D + ($B^($A|~$C)) + [lindex $X 7] + [lindex $T 50]}] 10]}] + set C [expr {$D + [<<< [expr {$C + ($A^($D|~$B)) + [lindex $X 14] + [lindex $T 51]}] 15]}] + set B [expr {$C + [<<< [expr {$B + ($D^($C|~$A)) + [lindex $X 5] + [lindex $T 52]}] 21]}] + # [ABCD 12 6 53] [DABC 3 10 54] [CDAB 10 15 55] [BCDA 1 21 56] + set A [expr {$B + [<<< [expr {$A + ($C^($B|~$D)) + [lindex $X 12] + [lindex $T 53]}] 6]}] + set D [expr {$A + [<<< [expr {$D + ($B^($A|~$C)) + [lindex $X 3] + [lindex $T 54]}] 10]}] + set C [expr {$D + [<<< [expr {$C + ($A^($D|~$B)) + [lindex $X 10] + [lindex $T 55]}] 15]}] + set B [expr {$C + [<<< [expr {$B + ($D^($C|~$A)) + [lindex $X 1] + [lindex $T 56]}] 21]}] + # [ABCD 8 6 57] [DABC 15 10 58] [CDAB 6 15 59] [BCDA 13 21 60] + set A [expr {$B + [<<< [expr {$A + ($C^($B|~$D)) + [lindex $X 8] + [lindex $T 57]}] 6]}] + set D [expr {$A + [<<< [expr {$D + ($B^($A|~$C)) + [lindex $X 15] + [lindex $T 58]}] 10]}] + set C [expr {$D + [<<< [expr {$C + ($A^($D|~$B)) + [lindex $X 6] + [lindex $T 59]}] 15]}] + set B [expr {$C + [<<< [expr {$B + ($D^($C|~$A)) + [lindex $X 13] + [lindex $T 60]}] 21]}] + # [ABCD 4 6 61] [DABC 11 10 62] [CDAB 2 15 63] [BCDA 9 21 64] + set A [expr {$B + [<<< [expr {$A + ($C^($B|~$D)) + [lindex $X 4] + [lindex $T 61]}] 6]}] + set D [expr {$A + [<<< [expr {$D + ($B^($A|~$C)) + [lindex $X 11] + [lindex $T 62]}] 10]}] + set C [expr {$D + [<<< [expr {$C + ($A^($D|~$B)) + [lindex $X 2] + [lindex $T 63]}] 15]}] + set B [expr {$C + [<<< [expr {$B + ($D^($C|~$A)) + [lindex $X 9] + [lindex $T 64]}] 21]}] + + # Then perform the following additions. (That is increment each + # of the four registers by the value it had before this block + # was started.) + incr A $AA + incr B $BB + incr C $CC + incr D $DD + } + # 3.5 Step 5. Output + + # ... begin with the low-order byte of A, and end with the high-order byte + # of D. + + binary format iiii $A $B $C $D +} + + +# bitwise left-rotate +proc md5pure::<<< {x i} { + # This works by bitwise-ORing together right piece and left + # piece so that the (original) right piece becomes the left + # piece and vice versa. + # + # The (original) right piece is a simple left shift. + # The (original) left piece should be a simple right shift + # but Tcl does sign extension on right shifts so we + # shift it 1 bit, mask off the sign, and finally shift + # it the rest of the way. + + expr {($x << $i) | ((($x >> 1) & 0x7fffffff) >> (31-$i))} +} + +#proc md5pure::F {x y z} {expr {(($x & $y) | ((~$x) & $z))}} +#proc md5pure::G {x y z} {expr {(($x & $z) | ($y & (~$z)))}} +#proc md5pure::H {x y z} {expr {$x ^ $y ^ $z}} +#proc md5pure::I {x y z} {expr {$y ^ ($x | (~$z))}} + +#proc md5pure::byte0 {i} {expr {0xff & $i}} +#proc md5pure::byte1 {i} {expr {(0xff00 & $i) >> 8}} +#proc md5pure::byte2 {i} {expr {(0xff0000 & $i) >> 16}} +#proc md5pure::byte3 {i} {expr {((0xff000000 & $i) >> 24) & 0xff}} + +#proc md5pure::bytes {i} { +# format %0.2x%0.2x%0.2x%0.2x [byte0 $i] [byte1 $i] [byte2 $i] [byte3 $i] +#} + +# hmac: hash for message authentication +proc md5pure::hmac {key text} { + # if key is longer than 64 bytes, reset it to MD5(key). If shorter, + # pad it out with null (\x00) chars. + set keyLen [string length $key] + if {$keyLen > 64} { + set key [md5 $key] + set keyLen [string length $key] + } + + # ensure the key is padded out to 64 chars with nulls. + set padLen [expr {64 - $keyLen}] + append key [binary format "a$padLen" {}] + + # Split apart the key into a list of 16 little-endian words + binary scan $key i16 blocks + + # XOR key with ipad and opad values + set k_ipad {} + set k_opad {} + foreach i $blocks { + append k_ipad [binary format i [expr {$i ^ 0x36363636}]] + append k_opad [binary format i [expr {$i ^ 0x5c5c5c5c}]] + } + + # Perform inner md5, appending its results to the outer key + append k_ipad $text + append k_opad [md5 $k_ipad] + + # Perform outer md5 + binary scan [md5 $k_opad] H* result + return $result +} + +package provide md5pure 1.2 DELETED mail.tcl Index: mail.tcl ================================================================== --- mail.tcl +++ /dev/null @@ -1,176 +0,0 @@ -#source $SRCDIR/post.tcl -namespace eval ::mail { - namespace export mailform mailformaccept mailsend - - proc row {c1 c2 args} { - if {[string length $c1]} { - puts -nonewline "$c1" - } else { - puts -nonewline "" - } - puts [eval [list format "$c2"] $args] - } - proc row_a {c1 c2 args} { - if {[string length $c1]} { - puts -nonewline "$c1" - } else { - puts -nonewline "" - } - puts [eval [list format "$c2"] $args] - } - - proc dotify {str} { - regsub -all {\.} $str " dot " str - return $str - } - - proc mailform {name user sys tipnum} { - global BASEURL CSSURL ICONURL DOCTYPE DOCDIR TCLCOREMAIL SENDMAILURL - if {![string length $name]} { - set syntheticName 1 - set hname "${user}_at_${sys}" - set name [dotify "$user at $sys"] - } else { - set hname $name - } - puts "Content-Type: text/html; charset=iso-8859-1" - puts "" - puts $DOCTYPE - puts "Compose Mail to $hname About\ - TIP#$tipnum" - puts "" - puts "" - puts "" - puts "" - puts "" - puts "" - puts "

    Composing Email Message to $name About TIP#$tipnum

    " - puts "
    " - set hide [list user $user sys $sys tipnum $tipnum] - if {![info exist syntheticName]} { - lappend hide name $name - } - row From: "" - row "" "

    Please note that you will be Cc'ed with\ - whatever message you create here, so you can retain a record\ - of your messages if you wish.

    " - row To: "%s <%s at %s>" \ - $name [dotify $user] [dotify $sys] - foreach {tc_user tc_sys} [split $TCLCOREMAIL @] {break} - if { - [string compare $user $tc_user] || - [string compare $sys $tc_sys] - } then { - row "" " Send Cc: to %s at %s" \ - [dotify $tc_user] [dotify $tc_sys] - } - if {[regexp {^[0-9]+$} $tipnum]} { - array set tipd [getTIPDetails [file join $DOCDIR $tipnum.tip]] - row Subject: "Re: TIP#%d: %s" $tipnum $tipd(Title) - lappend hide subject "Re: TIP#${tipnum}: $tipd(Title)" - } else { - row Subject: "" - } - row_a Body: "" - puts "
     
    " - if {[info exist ::env(HTTP_REFERER)]} { - lappend hide ref $::env(HTTP_REFERER) - } else { - lappend hide ref $BASEURL/$tipnum - } - foreach {key val} $hide { - regsub -all & $val {\&} val - regsub -all < $val {\<} val - regsub -all > $val {\>} val - regsub -all \" $val {\"} val - puts "" - } - puts -nonewline "
    " - basicHTMLfooter - exit - } - - proc mailformaccept {} { - variable ::post::name ;#"NO NAME" - variable ::post::user ;#no.name - variable ::post::sys ;#all - variable ::post::tipnum ;#-1 - variable ::post::from ;#test@foo.bar - variable ::post::subject ;#TEST - variable ::post::body ;#"TESTING...\r\n1, 2, 3, 4, 5\r\n" - variable ::post::ref ;#$::BASEURL - variable ::post::cccore ;#{} - - if {![regexp {^[^,]+@[^,]+\.[^,]+$} $from]} { - generr "Bad From Email Address" \ - "this system will not send mail purporting to come\ - from $from" - } - if {[regexp {[^a-zA-Z0-9_.]} $user]||[regexp {[^a-zA-Z0-9_.]} $sys]} { - generr "Bad To Email Address" \ - "this system will not send mail to [dotify $user] at [dotify $sys]" - } - - #::post::getVars - set cccore [expr {[info exist cccore] && [string length $cccore]}] - if {![info exist name]} { - set name {} - } - # Apply the CRLF->LF translation ourselves - regsub -all "\r\n" $body "\n" body - processmail $name $user $sys $tipnum $from $subject $body $ref $cccore - } - - proc addmailhdr {var key val} { - # Effectively a sanitised append - upvar 1 $var v - regsub -all "\[\r\n\t \]+" $val " " val - append v "${key}: $val\n" - } - proc processmail {name user sys tipnum from subject body ref cccore} { - global env TCLCOREMAIL - - set hdr "" - addmailhdr hdr From $from - addmailhdr hdr Cc $from - addmailhdr hdr To "$name <$user@$sys>" - addmailhdr hdr Subject $subject - if {$cccore} { - addmailhdr hdr Cc $TCLCOREMAIL - } - addmailhdr hdr Errors-To donal.fellows@man.ac.uk - addmailhdr hdr X-Tip-Number $tipnum - addmailhdr hdr MIME-Version 1.0 - addmailhdr hdr Content-Type {text/plain; charset=iso-8859-1} - addmailhdr hdr Content-Transfer-Encoding 8bit - addmailhdr hdr Date [clock format [clock seconds] -gmt 1 -format \ - "%a, %d %b %Y %H:%M:%S +0000\n"] - addmailhdr hdr X-Note "Message generated through web interface" - catch {addmailhdr hdr X-Submitting-Ip $env(REMOTE_ADDR)} - catch {addmailhdr hdr X-Submitting-User-Agent $env(HTTP_USER_AGENT)} - - mailsend $hdr\n[string trim $body \n]\n - - # Redirect back to where we originally came from - puts "Location: $ref\n" - } - - proc mailsend {message {redir 0}} { - global SENDMAIL - if {$redir} { - exec $SENDMAIL -oi -t <<$message >@stdout 2>@stderr - } else { - exec $SENDMAIL -oi -t <<$message - } - } -} DELETED mailnote.tcl Index: mailnote.tcl ================================================================== --- mailnote.tcl +++ /dev/null @@ -1,94 +0,0 @@ -#! /bin/sh -# \ -exec tclsh "$0" ${1+"$@"} - -### READ STANDARD CONFIG ### -set SRCDIR [file join [pwd] [file dir $argv0]] -source $SRCDIR/config.tcl - -### NEW GLOBALS WITH POSSIBLE VALUES ### - -# NOTIFYDB = [file join [file dir $LOGFILE] notify.db] -# ID = /usr/bin/id -# MAILX = /usr/bin/mailx -# WEBEDITID = tclhttpd -# NOTIFYURL = ${BASEURL}notify.html - -### HELPER PROCEDURES ### -proc readNotifyDB {} { - # NB This procedure needs some kind of locking protocol... - - global NOTIFYDB - set fid [open $NOTIFYDB r] - set lines [read $fid] - close $fid - return $lines -} -proc readLogMessage {} { - set lines {} - set readlog 0 - while {[gets stdin line]} { - if {$readlog} { - lappend lines $line - } else { - set readlog [string match "Log Message:" $line] - } - } - return [join $lines "\n"] -} -proc getUserID {} { - global ID - if {[regexp {uid=[0-9]+\([a-zA-Z0-9_]+\)} [exec $ID] -> id]} { - return $id - } else { - return "unknown user" - } -} -proc mail {address subject args} { - global MAILX - set body [join $args "\n\n"] - exec $MAILX -s $subject $address << "$body\n" -} - -### IMPLEMENTATION ### - -# Read this first; probably ought to add some kind of locking mechanism. -set notifylines [readNotifyDB] - -set logmsg [readLogMessage] - -set id [getUserID] -if {![string compare $id $WEBEDITID]} { - set mod "Modified over the web (see log message)" -} else { - set mod "Modified by: $id" -} - -# changed($file) exists if $file was changed -array set changed {} -foreach file $argv { - set changed($file) $file -} - -foreach line [split $notifylines "\n"] { - if {[regexp "^(\[0-9\]+)\[ \t\]+(.*@.*)" $line -> tip mail]} { - catch { - # if $email didn't want to be notified about any of the - # files mentioned in this log notification, then the - # reading of changed($tip.tip) will fail - mail $mail "\[TIP Archive] $changed($tip.tip) modified" \ - "TIP #$tip has been modified, and you might wish to\ - check it out.\n $BASEURL$tip.html" "To remove your\ - email address from the notification list for this\ - TIP,\nvisit the page, confirm your email address and\ - select 'Remove':\n $NOTIFYURL?tip=$tip,email=$mail" \ - "Log message associated with the update is as\ - follows:\n$logmsg" - } - } elseif {[regexp {^\*(.*@.*)} $line -> mail]} { - mail $mail "\[TIP Archive] update done" "Files modified: $argv\n$mod"\ - "Log message:\n$logmsg" - } -} - -exit DELETED makeconfig.tcl Index: makeconfig.tcl ================================================================== --- makeconfig.tcl +++ /dev/null @@ -1,340 +0,0 @@ -#! /bin/sh -# Re-execute using wish \ -exec wish "$0" $* - - -### ATTEMPT TO LOAD PREVIOUSLY-CREATED VERSION AND SET UP SRCDIR VAR ### -set SRCDIR [file join [pwd] [file dir $argv0]] -regsub -all {/\./} $SRCDIR / SRCDIR -regsub -all {/\.$} $SRCDIR {} SRCDIR - -namespace eval configure { - variable conffile [file join $::SRCDIR config.tcl] - variable deffile [file join $::SRCDIR conf_def.tcl] - variable showall \ - [expr {[string compare [lindex $::argv 0] "-expert"] == 0}] - - variable variables {} - variable optional {} - variable pages {} - variable header {} - variable introMessage {} - variable postUserScript {} -} - -puts "Loading old configuration: $::configure::conffile" -catch {source $::configure::conffile} - -puts "Loading setup: $::configure::deffile" -source $::configure::deffile - -namespace eval configure { - namespace export runGUI writeConfig - - variable name - set name() $introMessage - variable kinds - set kinds() message - - ### HELPER PROCEDURES ### - proc selectColour {var} { - variable name - upvar #0 $var colourVar - set col [tk_chooseColor -parent .t -initialcolor $colourVar \ - -title $name($var)] - if {[string length $col]} { - set colourVar $col - } - } - proc selectFile {var} { - variable name - upvar #0 $var fileVar - set file [tk_getOpenFile -parent .t -initialdir [file dir $fileVar] \ - -title $name($var)] - if {[string length $file]} { - set fileVar $file - } - } - proc selectDir {var} { - variable name - upvar #0 $var dirVar - set dir [tk_chooseDirectory -parent .t -initialdir $dirVar \ - -title $name($var) -mustexist 1] - if {[string length $dir]} { - set dirVar $dir - } - } - - ### BALLOON HELP ### - proc balloonIn {w msg} { - if {![winfo exist .balloon]} { - toplevel .balloon - wm overrideredirect .balloon 1 - label .balloon.l -foreground blue -background yellow \ - -highlightthick 0 -relief solid -borderwidth 1 \ - -font {Helvetica -10} -textvariable ::configure::balloon - pack .balloon.l - } - variable balloon $msg - set x [expr {[winfo rootx $w]+10}] - set y [expr {[winfo rooty $w]+[winfo height $w]+5}] - set g [format +%d+%d $x $y] - wm geometry .balloon $g - wm deiconify .balloon - wm geometry .balloon $g - raise .balloon - after idle "[list wm geometry .balloon $g]; raise .balloon" - } - proc balloonOut {} { - if {[winfo exist .balloon]} { - wm withdraw .balloon - } - } - proc bindBalloon {msg r args} { - foreach w $args { - bind $w [namespace code [list balloonIn $r $msg]] - bind $w [namespace code balloonOut] - } - } - - ### HANDLE THE GUI FOR A SINGLE EDITING PAGE ### - proc displayPage {pagedesc first last} { - variable forwardback - variable kinds - variable name - variable showall - - toplevel .t - wm title .t [lindex $pagedesc 0] - wm geometry .t +80+80 - set i 0 - set serif {Times 14} - set sans {Helvetica 14} - set ss {Helvetica 10 bold} - set mono {Courier 10} - set bold {Helvetica 18 bold} - set focusmagic {} - - set havedirb [llength [info command tk_chooseDirectory]] - set havespin [llength [info command spinbox]] - - foreach var [lrange $pagedesc 1 end] { - set kind $kinds($var) - switch $kind { - message {#ignore} - dir { - if {$havedirb} { - set msg "Please choose a directory (you can use the\ - button at the right to summon a directory\ - browser.)" - } else { - set msg "Please choose a directory." - set kind string - } - } - file { - set msg "Please choose a file (you can use the\ - button at the right to summon a file browser.)" - } - color - colour { - set msg "Please choose a $kind (you can use the button\ - at the right to summon a $kind browser.)" - } - string { - set msg "Input a string value here." - } - number { - set msg "Input a numeric value here." - if {!$havespin} {set kind string} - } - boolean { - set msg "Click here to toggle this feature on or off." - } - } - if {$showall && [string length $var]} { - set msg "Variable: $var" - } - switch $kind { - message { - pack [message .t.m$i -text $name($var) -font $serif \ - -anchor w] -fill x -expand 1 - bind .t [list .t.m$i configure -width %w] - } - dir { - lappend focusmagic .t.f$i.e - label .t.l$i -text $name($var) -anchor w -font $serif - pack .t.l$i [frame .t.f$i] -fill x -expand 1 - entry .t.f$i.e -textvariable $var -bg white -font $mono - button .t.f$i.b -text "Browse" -font $ss -takefocus 0 \ - -command [list selectDir $var] -padx 2 -pady 0 - pack .t.f$i.e .t.f$i.b -fill both -side left - pack configure .t.f$i.e -expand 1 - bindBalloon $msg .t.f$i .t.l$i .t.f$i.e .t.f$i.b - } - file { - lappend focusmagic .t.f$i.e - label .t.l$i -text $name($var) -anchor w -font $serif - pack .t.l$i [frame .t.f$i] -fill x -expand 1 - entry .t.f$i.e -textvariable $var -bg white -font $mono - button .t.f$i.b -text "Browse" -font $ss -takefocus 0 \ - -command [list selectFile $var] -padx 2 -pady 0 - pack .t.f$i.e .t.f$i.b -fill both -side left - pack configure .t.f$i.e -expand 1 - bindBalloon $msg .t.f$i .t.l$i .t.f$i.e .t.f$i.b - } - color - colour { - lappend focusmagic .t.f$i.e - label .t.l$i -text $name($var) -anchor w -font $serif - pack .t.l$i [frame .t.f$i] -fill x -expand 1 - entry .t.f$i.e -textvariable $var -bg white -font $mono - button .t.f$i.b -text "Browse" -font $ss -takefocus 0 \ - -command [list selectColour $var] -padx 2 -pady 0 - pack .t.f$i.e .t.f$i.b -fill both -side left - pack configure .t.f$i.e -expand 1 - bindBalloon $msg .t.f$i .t.l$i .t.f$i.e .t.f$i.b - } - string { - lappend focusmagic .t.e$i - label .t.l$i -text $name($var) -anchor w -font $serif - entry .t.e$i -textvariable $var -bg white -font $mono - pack .t.l$i .t.e$i -fill x -expand 1 - bindBalloon $msg .t.e$i .t.l$i .t.e$i - } - number { - lappend focusmagic .t.e$i - label .t.l$i -text $name($var) -anchor w -font $serif - spinbox .t.e$i -textvariable $var -bg white -font $mono - pack .t.l$i .t.e$i -fill x -expand 1 - bind .t.e$i [list incr $var] - bind .t.e$i [list incr $var -1] - bindBalloon $msg .t.e$i .t.l$i .t.e$i - } - boolean { - lappend focusmagic .t.b$i - pack [checkbutton .t.b$i -text $name($var) -anchor w \ - -font $sans -variable $var] -fill x -expand 1 - bindBalloon $msg .t.b$i .t.b$i - } - } - incr i - } - pack [frame .t.bottom] -expand 1 -fill both - button .t.bottom.left -text "<< Back" -font $bold -default normal \ - -command {set ::configure::forwardback -1} - if {$first} { - .t.bottom.left configure -state disabled -font $bold - bind .t {set ::configure::forwardback 0} - } else { - bind .t {set ::configure::forwardback -1} - } - button .t.bottom.middle -text "Cancel" -font $bold -default normal \ - -command {set ::configure::forwardback 0} - button .t.bottom.right -text "Next >>" -font $bold -default active \ - -command {set ::configure::forwardback 1} - if {$last} { - .t.bottom.right configure -text "Write Config" - } - pack .t.bottom.left .t.bottom.middle .t.bottom.right \ - -expand 1 -fill both -side left - bind .t.bottom {set ::configure::forwardback 0} - bind .t {set ::configure::forwardback 1} - if {[string length $focusmagic]} { - focus [lindex $focusmagic 0] - } else { - focus .t.bottom.right - } - vwait ::configure::forwardback - if {[winfo exist .t.bottom]} { - bind .t.bottom {} - destroy .t - } - return $forwardback - } - - ### RUN THE CONFIGURATION GUI ### - proc runGUI {} { - variable showall - variable kinds - variable variables - variable optional - variable pages - variable name - - set pageidx 0 - set step 1 - array set defs {} - while {$step && $pageidx>=0} { - foreach {var kind val doc} $variables { - set name($var) $doc - set dynamic [regexp {[\[$]} $val] - if {$dynamic || ![info exist ::$var]} { - if {$dynamic} { - set defs($var) $val - } - set ::$var [uplevel #0 [list subst $val]] - } - set kinds($var) $kind - } - - while {$pageidx < [llength $pages]} { - set page [lindex $pages $pageidx] - foreach var [lrange $page 1 end] { - if {[string length $var] && [info exist defs($var)]} { - set ::$var [uplevel #0 [list subst $defs($var)]] - #puts "$var = [set ::$var]" - } - } - if {$showall || [lsearch $optional [lindex $page 1]]<0} { - set step [displayPage $page [expr {$pageidx==0}] \ - [expr {$pageidx==[llength $pages]-1}]] - } - if {!$step} { - return 0 - } - incr pageidx $step - } - set done 1 - foreach {var ? ? ?} $variables { - if {![string length [set ::$var]]} { - tk_messageBox -type ok -icon error \ - -title "Missing value" \ - -message "You must supply a value for all fields" - set done 0 - set pageidx 1 - set step 1 - break - } - } - if {$done} {break} - } - - return [expr {$step > 0}] - } - - ### WRITE THE NEW VERSION OF THE CONFIGURATION FILE ### - proc writeConfig {} { - variable conffile - variable variables - variable header - - set fid [open $conffile w] - foreach line [split $header "\n"] { - puts $fid [string trimleft $line] - } - foreach {var ? ? ?} $variables { - puts $fid [list set $var [set ::$var]] - } - close $fid - } -} - -### TOP LEVEL CODE ### -wm withdraw . -if {[configure::runGUI]} { - eval $configure::postUserScript - puts "Writing new configuration: $::configure::conffile" - configure::writeConfig -} else { - puts "Cancelled; $::configure::conffile unchanged" -} -exit DELETED md5.tcl Index: md5.tcl ================================================================== --- md5.tcl +++ /dev/null @@ -1,347 +0,0 @@ -################################################## -# -# md5.tcl - MD5 in Tcl -# Author: Don Libes , July 1999 -# Version 1.2.0 -# -# MD5 defined by RFC 1321, "The MD5 Message-Digest Algorithm" -# HMAC defined by RFC 2104, "Keyed-Hashing for Message Authentication" -# -# Most of the comments below come right out of RFC 1321; That's why -# they have such peculiar numbers. In addition, I have retained -# original syntax, bugs in documentation (yes, really), etc. from the -# RFC. All remaining bugs are mine. -# -# HMAC implementation by D. J. Hagberg and -# is based on C code in RFC 2104. -# -# For more info, see: http://expect.nist.gov/md5pure -# -# - Don -################################################## - -### Code speedups by Donal Fellows who may well -### have added some extra bugs of his own... :^) - -namespace eval md5pure { - variable T { - #PADDING - - 0xd76aa478 0xe8c7b756 0x242070db 0xc1bdceee - 0xf57c0faf 0x4787c62a 0xa8304613 0xfd469501 - 0x698098d8 0x8b44f7af 0xffff5bb1 0x895cd7be - 0x6b901122 0xfd987193 0xa679438e 0x49b40821 - - 0xf61e2562 0xc040b340 0x265e5a51 0xe9b6c7aa - 0xd62f105d 0x2441453 0xd8a1e681 0xe7d3fbc8 - 0x21e1cde6 0xc33707d6 0xf4d50d87 0x455a14ed - 0xa9e3e905 0xfcefa3f8 0x676f02d9 0x8d2a4c8a - - 0xfffa3942 0x8771f681 0x6d9d6122 0xfde5380c - 0xa4beea44 0x4bdecfa9 0xf6bb4b60 0xbebfbc70 - 0x289b7ec6 0xeaa127fa 0xd4ef3085 0x4881d05 - 0xd9d4d039 0xe6db99e5 0x1fa27cf8 0xc4ac5665 - - 0xf4292244 0x432aff97 0xab9423a7 0xfc93a039 - 0x655b59c3 0x8f0ccc92 0xffeff47d 0x85845dd1 - 0x6fa87e4f 0xfe2ce6e0 0xa3014314 0x4e0811a1 - 0xf7537e82 0xbd3af235 0x2ad7d2bb 0xeb86d391 - } -} - -# test md5pure -# -# This proc is not necessary during runtime and may be omitted if you -# are simply inserting this file into a production program. -# -proc md5pure::test {} { - foreach {msg expected} { - "" - "d41d8cd98f00b204e9800998ecf8427e" - "a" - "0cc175b9c0f1b6a831c399e269772661" - "abc" - "900150983cd24fb0d6963f7d28e17f72" - "message digest" - "f96b697d7cb7938d525a2f31aaf161d0" - "abcdefghijklmnopqrstuvwxyz" - "c3fcd3d76192e4007dfb496cca67e13b" - "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" - "d174ab98d277d9f5a5611c2c9f419d9f" - "12345678901234567890123456789012345678901234567890123456789012345678901234567890" - "57edf4a22be3c955ac49da2e2107b67a" - } { - puts "testing: md5 \"$msg\"" - binary scan [md5 $msg] H32 computed - puts "expected: $expected" - puts "computed: $computed" - if {0 != [string compare $computed $expected]} { - puts "FAILED" - } else { - puts "SUCCEEDED" - } - } -} - -# time md5pure -# -# This proc is not necessary during runtime and may be omitted if you -# are simply inserting this file into a production program. -# -proc md5pure::time {} { - foreach len {10 50 100 500 1000 5000 10000} { - set time [::time {md5 [format %$len.0s ""]} 10] - regexp "\[0-9]*" $time msec - puts "input length $len: [expr {$msec/1000}] milliseconds per interation" - } -} - -proc md5pure::md5 {msg} { - variable T - - # - # 3.1 Step 1. Append Padding Bits - # - - set msgLen [string length $msg] - - set padLen [expr {56 - $msgLen%64}] - if {$msgLen % 64 > 56} { - incr padLen 64 - } - - # pad even if no padding required - if {$padLen == 0} { - incr padLen 64 - } - - # append single 1b followed by 0b's - append msg [binary format "a$padLen" \200] - - # - # 3.2 Step 2. Append Length - # - - # RFC doesn't say whether to use little- or big-endian - # code demonstrates little-endian - # This step limits our input to size 2^32b or 2^24B - append msg [binary format "i1i1" [expr {8*$msgLen}] 0] - - # - # 3.3 Step 3. Initialize MD Buffer - # - - set A [expr 0x67452301] - set B [expr 0xefcdab89] - set C [expr 0x98badcfe] - set D [expr 0x10325476] - - # - # 3.4 Step 4. Process Message in 16-Word Blocks - # - - # process each 16-word block - # RFC doesn't say whether to use little- or big-endian - # code says little-endian - binary scan $msg i* blocks - #set i 0 - #foreach b $blocks { - # set M($i) $b - # incr i - #} - - set blockLen [llength $blocks] - - for {set i 0} {$i < $blockLen} {incr i 16} { - # copy block i into X - set X [lrange $blocks $i [expr {$i+15}]] - #for {set j 0} {$j<16} {incr j} { - # set X($j) $M([expr $i*16+$j]) - #} - - # Save A as AA, B as BB, C as CC, and D as DD. - set AA $A - set BB $B - set CC $C - set DD $D - - # Round 1. - # Let [abcd k s i] denote the operation - # a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s). - # [ABCD 0 7 1] [DABC 1 12 2] [CDAB 2 17 3] [BCDA 3 22 4] - set A [expr {$B + [<<< [expr {$A + (($B&$C)|((~$B)&$D)) + [lindex $X 0] + [lindex $T 1] }] 7]}] - set D [expr {$A + [<<< [expr {$D + (($A&$B)|((~$A)&$C)) + [lindex $X 1] + [lindex $T 2] }] 12]}] - set C [expr {$D + [<<< [expr {$C + (($D&$A)|((~$D)&$B)) + [lindex $X 2] + [lindex $T 3] }] 17]}] - set B [expr {$C + [<<< [expr {$B + (($C&$D)|((~$C)&$A)) + [lindex $X 3] + [lindex $T 4] }] 22]}] - # [ABCD 4 7 5] [DABC 5 12 6] [CDAB 6 17 7] [BCDA 7 22 8] - set A [expr {$B + [<<< [expr {$A + (($B&$C)|((~$B)&$D)) + [lindex $X 4] + [lindex $T 5] }] 7]}] - set D [expr {$A + [<<< [expr {$D + (($A&$B)|((~$A)&$C)) + [lindex $X 5] + [lindex $T 6] }] 12]}] - set C [expr {$D + [<<< [expr {$C + (($D&$A)|((~$D)&$B)) + [lindex $X 6] + [lindex $T 7] }] 17]}] - set B [expr {$C + [<<< [expr {$B + (($C&$D)|((~$C)&$A)) + [lindex $X 7] + [lindex $T 8] }] 22]}] - # [ABCD 8 7 9] [DABC 9 12 10] [CDAB 10 17 11] [BCDA 11 22 12] - set A [expr {$B + [<<< [expr {$A + (($B&$C)|((~$B)&$D)) + [lindex $X 8] + [lindex $T 9] }] 7]}] - set D [expr {$A + [<<< [expr {$D + (($A&$B)|((~$A)&$C)) + [lindex $X 9] + [lindex $T 10]}] 12]}] - set C [expr {$D + [<<< [expr {$C + (($D&$A)|((~$D)&$B)) + [lindex $X 10] + [lindex $T 11]}] 17]}] - set B [expr {$C + [<<< [expr {$B + (($C&$D)|((~$C)&$A)) + [lindex $X 11] + [lindex $T 12]}] 22]}] - # [ABCD 12 7 13] [DABC 13 12 14] [CDAB 14 17 15] [BCDA 15 22 16] - set A [expr {$B + [<<< [expr {$A + (($B&$C)|((~$B)&$D)) + [lindex $X 12] + [lindex $T 13]}] 7]}] - set D [expr {$A + [<<< [expr {$D + (($A&$B)|((~$A)&$C)) + [lindex $X 13] + [lindex $T 14]}] 12]}] - set C [expr {$D + [<<< [expr {$C + (($D&$A)|((~$D)&$B)) + [lindex $X 14] + [lindex $T 15]}] 17]}] - set B [expr {$C + [<<< [expr {$B + (($C&$D)|((~$C)&$A)) + [lindex $X 15] + [lindex $T 16]}] 22]}] - - # Round 2. - # Let [abcd k s i] denote the operation - # a = b + ((a + G(b,c,d) + X[k] + T[i]) <<< s). - # Do the following 16 operations. - # [ABCD 1 5 17] [DABC 6 9 18] [CDAB 11 14 19] [BCDA 0 20 20] - set A [expr {$B + [<<< [expr {$A + (($B&$D)|($C&(~$D))) + [lindex $X 1] + [lindex $T 17]}] 5]}] - set D [expr {$A + [<<< [expr {$D + (($A&$C)|($B&(~$C))) + [lindex $X 6] + [lindex $T 18]}] 9]}] - set C [expr {$D + [<<< [expr {$C + (($D&$B)|($A&(~$B))) + [lindex $X 11] + [lindex $T 19]}] 14]}] - set B [expr {$C + [<<< [expr {$B + (($C&$A)|($D&(~$A))) + [lindex $X 0] + [lindex $T 20]}] 20]}] - # [ABCD 5 5 21] [DABC 10 9 22] [CDAB 15 14 23] [BCDA 4 20 24] - set A [expr {$B + [<<< [expr {$A + (($B&$D)|($C&(~$D))) + [lindex $X 5] + [lindex $T 21]}] 5]}] - set D [expr {$A + [<<< [expr {$D + (($A&$C)|($B&(~$C))) + [lindex $X 10] + [lindex $T 22]}] 9]}] - set C [expr {$D + [<<< [expr {$C + (($D&$B)|($A&(~$B))) + [lindex $X 15] + [lindex $T 23]}] 14]}] - set B [expr {$C + [<<< [expr {$B + (($C&$A)|($D&(~$A))) + [lindex $X 4] + [lindex $T 24]}] 20]}] - # [ABCD 9 5 25] [DABC 14 9 26] [CDAB 3 14 27] [BCDA 8 20 28] - set A [expr {$B + [<<< [expr {$A + (($B&$D)|($C&(~$D))) + [lindex $X 9] + [lindex $T 25]}] 5]}] - set D [expr {$A + [<<< [expr {$D + (($A&$C)|($B&(~$C))) + [lindex $X 14] + [lindex $T 26]}] 9]}] - set C [expr {$D + [<<< [expr {$C + (($D&$B)|($A&(~$B))) + [lindex $X 3] + [lindex $T 27]}] 14]}] - set B [expr {$C + [<<< [expr {$B + (($C&$A)|($D&(~$A))) + [lindex $X 8] + [lindex $T 28]}] 20]}] - # [ABCD 13 5 29] [DABC 2 9 30] [CDAB 7 14 31] [BCDA 12 20 32] - set A [expr {$B + [<<< [expr {$A + (($B&$D)|($C&(~$D))) + [lindex $X 13] + [lindex $T 29]}] 5]}] - set D [expr {$A + [<<< [expr {$D + (($A&$C)|($B&(~$C))) + [lindex $X 2] + [lindex $T 30]}] 9]}] - set C [expr {$D + [<<< [expr {$C + (($D&$B)|($A&(~$B))) + [lindex $X 7] + [lindex $T 31]}] 14]}] - set B [expr {$C + [<<< [expr {$B + (($C&$A)|($D&(~$A))) + [lindex $X 12] + [lindex $T 32]}] 20]}] - - # Round 3. - # Let [abcd k s t] [sic] denote the operation - # a = b + ((a + H(b,c,d) + X[k] + T[i]) <<< s). - # Do the following 16 operations. - # [ABCD 5 4 33] [DABC 8 11 34] [CDAB 11 16 35] [BCDA 14 23 36] - set A [expr {$B + [<<< [expr {$A + ($B^$C^$D) + [lindex $X 5] + [lindex $T 33]}] 4]}] - set D [expr {$A + [<<< [expr {$D + ($A^$B^$C) + [lindex $X 8] + [lindex $T 34]}] 11]}] - set C [expr {$D + [<<< [expr {$C + ($D^$A^$B) + [lindex $X 11] + [lindex $T 35]}] 16]}] - set B [expr {$C + [<<< [expr {$B + ($C^$D^$A) + [lindex $X 14] + [lindex $T 36]}] 23]}] - # [ABCD 1 4 37] [DABC 4 11 38] [CDAB 7 16 39] [BCDA 10 23 40] - set A [expr {$B + [<<< [expr {$A + ($B^$C^$D) + [lindex $X 1] + [lindex $T 37]}] 4]}] - set D [expr {$A + [<<< [expr {$D + ($A^$B^$C) + [lindex $X 4] + [lindex $T 38]}] 11]}] - set C [expr {$D + [<<< [expr {$C + ($D^$A^$B) + [lindex $X 7] + [lindex $T 39]}] 16]}] - set B [expr {$C + [<<< [expr {$B + ($C^$D^$A) + [lindex $X 10] + [lindex $T 40]}] 23]}] - # [ABCD 13 4 41] [DABC 0 11 42] [CDAB 3 16 43] [BCDA 6 23 44] - set A [expr {$B + [<<< [expr {$A + ($B^$C^$D) + [lindex $X 13] + [lindex $T 41]}] 4]}] - set D [expr {$A + [<<< [expr {$D + ($A^$B^$C) + [lindex $X 0] + [lindex $T 42]}] 11]}] - set C [expr {$D + [<<< [expr {$C + ($D^$A^$B) + [lindex $X 3] + [lindex $T 43]}] 16]}] - set B [expr {$C + [<<< [expr {$B + ($C^$D^$A) + [lindex $X 6] + [lindex $T 44]}] 23]}] - # [ABCD 9 4 45] [DABC 12 11 46] [CDAB 15 16 47] [BCDA 2 23 48] - set A [expr {$B + [<<< [expr {$A + ($B^$C^$D) + [lindex $X 9] + [lindex $T 45]}] 4]}] - set D [expr {$A + [<<< [expr {$D + ($A^$B^$C) + [lindex $X 12] + [lindex $T 46]}] 11]}] - set C [expr {$D + [<<< [expr {$C + ($D^$A^$B) + [lindex $X 15] + [lindex $T 47]}] 16]}] - set B [expr {$C + [<<< [expr {$B + ($C^$D^$A) + [lindex $X 2] + [lindex $T 48]}] 23]}] - - # Round 4. - # Let [abcd k s t] [sic] denote the operation - # a = b + ((a + I(b,c,d) + X[k] + T[i]) <<< s). - # Do the following 16 operations. - # [ABCD 0 6 49] [DABC 7 10 50] [CDAB 14 15 51] [BCDA 5 21 52] - set A [expr {$B + [<<< [expr {$A + ($C^($B|~$D)) + [lindex $X 0] + [lindex $T 49]}] 6]}] - set D [expr {$A + [<<< [expr {$D + ($B^($A|~$C)) + [lindex $X 7] + [lindex $T 50]}] 10]}] - set C [expr {$D + [<<< [expr {$C + ($A^($D|~$B)) + [lindex $X 14] + [lindex $T 51]}] 15]}] - set B [expr {$C + [<<< [expr {$B + ($D^($C|~$A)) + [lindex $X 5] + [lindex $T 52]}] 21]}] - # [ABCD 12 6 53] [DABC 3 10 54] [CDAB 10 15 55] [BCDA 1 21 56] - set A [expr {$B + [<<< [expr {$A + ($C^($B|~$D)) + [lindex $X 12] + [lindex $T 53]}] 6]}] - set D [expr {$A + [<<< [expr {$D + ($B^($A|~$C)) + [lindex $X 3] + [lindex $T 54]}] 10]}] - set C [expr {$D + [<<< [expr {$C + ($A^($D|~$B)) + [lindex $X 10] + [lindex $T 55]}] 15]}] - set B [expr {$C + [<<< [expr {$B + ($D^($C|~$A)) + [lindex $X 1] + [lindex $T 56]}] 21]}] - # [ABCD 8 6 57] [DABC 15 10 58] [CDAB 6 15 59] [BCDA 13 21 60] - set A [expr {$B + [<<< [expr {$A + ($C^($B|~$D)) + [lindex $X 8] + [lindex $T 57]}] 6]}] - set D [expr {$A + [<<< [expr {$D + ($B^($A|~$C)) + [lindex $X 15] + [lindex $T 58]}] 10]}] - set C [expr {$D + [<<< [expr {$C + ($A^($D|~$B)) + [lindex $X 6] + [lindex $T 59]}] 15]}] - set B [expr {$C + [<<< [expr {$B + ($D^($C|~$A)) + [lindex $X 13] + [lindex $T 60]}] 21]}] - # [ABCD 4 6 61] [DABC 11 10 62] [CDAB 2 15 63] [BCDA 9 21 64] - set A [expr {$B + [<<< [expr {$A + ($C^($B|~$D)) + [lindex $X 4] + [lindex $T 61]}] 6]}] - set D [expr {$A + [<<< [expr {$D + ($B^($A|~$C)) + [lindex $X 11] + [lindex $T 62]}] 10]}] - set C [expr {$D + [<<< [expr {$C + ($A^($D|~$B)) + [lindex $X 2] + [lindex $T 63]}] 15]}] - set B [expr {$C + [<<< [expr {$B + ($D^($C|~$A)) + [lindex $X 9] + [lindex $T 64]}] 21]}] - - # Then perform the following additions. (That is increment each - # of the four registers by the value it had before this block - # was started.) - incr A $AA - incr B $BB - incr C $CC - incr D $DD - } - # 3.5 Step 5. Output - - # ... begin with the low-order byte of A, and end with the high-order byte - # of D. - - binary format iiii $A $B $C $D -} - - -# bitwise left-rotate -proc md5pure::<<< {x i} { - # This works by bitwise-ORing together right piece and left - # piece so that the (original) right piece becomes the left - # piece and vice versa. - # - # The (original) right piece is a simple left shift. - # The (original) left piece should be a simple right shift - # but Tcl does sign extension on right shifts so we - # shift it 1 bit, mask off the sign, and finally shift - # it the rest of the way. - - expr {($x << $i) | ((($x >> 1) & 0x7fffffff) >> (31-$i))} -} - -#proc md5pure::F {x y z} {expr {(($x & $y) | ((~$x) & $z))}} -#proc md5pure::G {x y z} {expr {(($x & $z) | ($y & (~$z)))}} -#proc md5pure::H {x y z} {expr {$x ^ $y ^ $z}} -#proc md5pure::I {x y z} {expr {$y ^ ($x | (~$z))}} - -#proc md5pure::byte0 {i} {expr {0xff & $i}} -#proc md5pure::byte1 {i} {expr {(0xff00 & $i) >> 8}} -#proc md5pure::byte2 {i} {expr {(0xff0000 & $i) >> 16}} -#proc md5pure::byte3 {i} {expr {((0xff000000 & $i) >> 24) & 0xff}} - -#proc md5pure::bytes {i} { -# format %0.2x%0.2x%0.2x%0.2x [byte0 $i] [byte1 $i] [byte2 $i] [byte3 $i] -#} - -# hmac: hash for message authentication -proc md5pure::hmac {key text} { - # if key is longer than 64 bytes, reset it to MD5(key). If shorter, - # pad it out with null (\x00) chars. - set keyLen [string length $key] - if {$keyLen > 64} { - set key [md5 $key] - set keyLen [string length $key] - } - - # ensure the key is padded out to 64 chars with nulls. - set padLen [expr {64 - $keyLen}] - append key [binary format "a$padLen" {}] - - # Split apart the key into a list of 16 little-endian words - binary scan $key i16 blocks - - # XOR key with ipad and opad values - set k_ipad {} - set k_opad {} - foreach i $blocks { - append k_ipad [binary format i [expr {$i ^ 0x36363636}]] - append k_opad [binary format i [expr {$i ^ 0x5c5c5c5c}]] - } - - # Perform inner md5, appending its results to the outer key - append k_ipad $text - append k_opad [md5 $k_ipad] - - # Perform outer md5 - binary scan [md5 $k_opad] H* result - return $result -} - -package provide md5pure 1.2 DELETED parse.tcl Index: parse.tcl ================================================================== --- parse.tcl +++ /dev/null @@ -1,450 +0,0 @@ -#! /usr/local/bin/tclsh8.0 - -# Regular expressions - suitable for 8.0 as well as later. -set ws "\[ \t\n\]" -set ParSepRE "^$ws*$" -set RFC822ContRE "^$ws" -set RFC822DataRE "^(\[^ \t:\]+):$ws+(.*)$" -set RFC822EmptyRE "^(\[^ \t:\]+):$" -set ItemNoLeadRE "^\[^ \t>\]" -set ItemLeadRE "^$ws*((>$ws+)*)(\\*|\[0-9\]+\\.|(\[^\t\n:\]|:\[^:\t\n\])+:)$ws" -set ItemContRE "^($ws+>)+$ws*" -# RE's for (optional) use in paragraphs -set AuthorRE "(.*$ws+)?<(\[^:@\]+@\[^:@\]+)>" -set ImageRE "^(\[^ \t\n\]+)$ws*(.*)$" -set EmailRE {<([^<>@]+@[^<>@]+)>} -set URLRE {(https?|ftp|news(rc)?|mailto|gopher):([-A-Za-z0-9/_:.%#+@?=&;~\\]+)} -set TIPURLRE {tip:([0-9]+)} -set ShortTIPRE {\[([0-9]+)\]} -set ISSUEURLRE {issue:([0-9]+)} - -# # Regular expressions - suitable for 8.1 and later only. It is easier to -# # understand the above by looking at the below and translating... :^) -# -# set ParSepRE {^\s*$} -# set RFC822ContRE {^\s} -# set RFC822DataRE {^([^\s:]+):\s*(.*)$} -# set RFC822EmptyRE {^([^\s:]+):\s*$} -# set ItemNoLeadRE {^[\s>]} -# set ItemLeadRE {^\s*((>\s+)*)(\*|\d+\.|(?:[^\t\n:]|:(?=\S))+:)\s} -# set ItemContRE {^(\s+>)+\s*} -# # RE's for (optional) use in paragraphs -# set AuthorRE {(.*\s+)?<(.*?@.*)>} -# set ImageRE {^(\S+)\s*(.*)$} -# set EmailRE {<([^<>@]+@[^<>@]+)>} -# set URLRE {(https?|ftp|news(?:rc)?|mailto|gopher):([-A-Za-z0-9/_:.#+@?=&;~\\]+)} -# set TIPURLRE {tip:(\d+)} -# set ShortTIPRE {\[(\d+)\]} -# set ISSUEURLRE {issue:(\d+)} -# -# # Note that ItemLeadRE would be clearer if written as: -# # ^\s*((?:>\s+)*)(\*|\d+\.|(?:[^\t\n:]|:(?=\S))+:)\s -# # but that would be incompatible with the 8.0 version. - -proc splitIntoParagraphs {string} { - global ParSepRE - set paragraphs {} - set current {} - foreach line [split $string "\n"] { - if {[regexp $ParSepRE $line]} { - # (VISUALLY) BLANK LINE = PARAGRAPH SEPARATOR - if {[string length $current]} { - lappend paragraphs [string trim $current "\n"] - set current {} - } - continue - } - append current "\n$line" - } - if {[string length $current]} { - lappend paragraphs [string trim $current "\n"] - } - return $paragraphs -} - -proc splitRFC822Header {paragraph} { - global RFC822ContRE RFC822DataRE RFC822EmptyRE - set properlines {} - set current {} - foreach line [split $paragraph "\n"] { - if {[regexp $RFC822ContRE $line]} { - append current $line - continue - } - if {[string length $current]} { - if {[regexp $RFC822DataRE $current -> tag value]} { - lappend properlines $tag $value - } elseif {[regexp $RFC822EmptyRE $current -> tag]} { - lappend properlines $tag {} - } else { - return -code error "header \"$current\" malformatted" - } - } - set current $line - } - if {[string length $current]} { - if {[regexp $RFC822DataRE $current -> tag value]} { - lappend properlines $tag $value - } elseif {[regexp $RFC822EmptyRE $current -> tag]} { - lappend properlines $tag {} - } else { - return -code error "header \"$current\" malformatted" - } - } - return $properlines -} - -proc TIPHeaderSpecification {permitted required} { - upvar 1 $permitted formatREs $required neededHeaders - # A header is only permitted if it is a key in this array, and the value - # in the array is the regexp that the value in the field (after - # un-stuffing) must satisfy. - array set formatREs { - TIP {^[0-9]+$} - Title {.} - Version {^\$.*\$ *$} - Author {<.+@.+\..+>} - State {^(Draft|Active|Accepted|Deferred|Final|Rejected|Withdrawn)$} - Type {^(Process|Project|Informati(ve|on(al)?))$} - Vote {^(Pending|In progress|Done|No voting)$} - Created {^[0-3][0-9]-[A-Z][a-z][a-z]-2[0-9][0-9][0-9]$} - Post-History {.*} - Tcl-Version {^[0-9]+\.[0-9]+([ab.][0-9]+)?$} - Discussions-To {.} - Obsoletes {^[0-9]+$} - Obsoleted-By {^[0-9]+$} - Keywords {.} - Vote-By {^[0-9]+$} - Voted-For {.} - Voted-Against {.} - Voted-Abstained {.} - } - # A list of headers that *must* be present in a conforming TIP. - set neededHeaders { - TIP Title Version Author State Type Vote Created Post-History - } - ## Headers that may occur multiple times in a conforming TIP. All others - ## must occur at most once. - #set multipleHeaders { - # Author - #} -} - -# takes output of splitRFC822Header -proc verifyTIPheader {headerlines} { - array set headers {} - TIPHeaderSpecification permitted required - - foreach {tag value} $headerlines { - if {![info exists permitted($tag)]} { - return -code error "header \"${tag}: $value\" not understood" - } - if {![regexp $permitted($tag) $value]} { - return -code error "header \"${tag}: $value\" malformatted" - } - if {[string compare $tag Author]} { - if {[info exists headers($tag)]} { - return -code error "header for \"${tag}:\" can only occur once" - } - set headers($tag) $value - } else { - lappend headers($tag) $value - } - } - foreach tag $required { - if {![info exist headers($tag)]} { - return -code error "header for \"${tag}:\" is required" - } - } - if {[string match Info* $headers(Type)]} { - set headers(Type) Informative - } - if {[info exist headers(Keywords)]} { - set kws {} - foreach keyword [split $headers(Keywords) ","] { - regsub -all "\[ \t\n\]+" $keyword " " keyword - lappend kws [string trim $keyword] - } - set headers(Keywords) $kws - } - # This check is complex... - if {[info exist headers(Tcl-Version)] != ![string compare $headers(Type) Project]} { - return -code error "header \"Tcl-Version:\" iff a project TIP" - } - # Force the created header into processable form - regsub -all -- (.+)-(.+)-(.+) $headers(Created) {\2 \1, \3} date - set headers(Created) [clock scan $date -gmt 1] - # Now return as association list - return [array get headers] -} - -proc makeHeaderLine {tag value} { - set line $tag: - set numSpaces [expr {16 - [string length $tag]}] - while {[incr numSpaces -1]} { - append line " " - } - append line $value - return $line -} - -proc constructTIPHeader {headerData} { - array set headers $headerData - # Remove RawAbstract, Abstract and Body entries, if any - catch {unset headers(RawAbstract)} - catch {unset headers(Abstract)} - catch {unset headers(Body)} - - TIPHeaderSpecification permitted required - set headerLines [list] - foreach tag $required { - if {![info exists headers($tag)]} { - return -code error "header for \"${tag}\" is required" - } - set value $headers($tag) - # Created tag needs restoration to standard form - if {[string match Created $tag]} { - set value [clock format $value -format %d-%b-%Y -gmt 1] - } - if {![regexp $permitted($tag) $value]} { - return -code error "header \"${tag}: $value\" malformatted" - } - # Author tag needs special handling - if {[string match Author $tag]} { - foreach author $value { - if {![regexp $permitted($tag) $author]} { - return -code error "header \"${tag}: $value\" malformatted" - } - lappend headerLines [makeHeaderLine Author $author] - } - unset headers($tag) - continue - } - lappend headerLines [makeHeaderLine $tag $value] - unset headers($tag) - } - foreach tag [lsort [array names headers]] { - if {![info exists permitted($tag)]} { - return -code error "header \"${tag}: $value\" not understood" - } - set value $headers($tag) - if {![regexp $permitted($tag) $value]} { - return -code error "header \"${tag}: $value\" malformatted" - } - if {[string match Keywords $tag]} { - lappend headerLines [makeHeaderLine $tag [join $value ","]] - } else { - lappend headerLines [makeHeaderLine $tag $value] - } - } - return [join $headerLines \n] -} - -proc notEditable? {headerArray} { - upvar 1 $headerArray h - expr {[string compare Draft $h(State)]||[string compare Pending $h(Vote)]} -} - -proc shortspc {string} { - regsub -all {[ - ]+} $string " " string - return $string -} -proc intuitParagraphKind {paragraph} { - switch -glob -- $paragraph { - ~* { - # easier to express in 8.1 as {^((?:~ *){1,3})(.*)} - regexp {^(~( *~)?( *~)?) *(.*)$} $paragraph -> \ - levelmark ? ? content - # Count the number of tildes in the level-mark - set level [regsub -all ~ $levelmark x levelmark] - return [list section [string trim [shortspc $content]] $level] - } - |* { - set lines {} - foreach line [split $paragraph "\n"] { - if {![string match |* $line]} { - variable DEBUG_VERBATIM - if {$DEBUG_VERBATIM} { - return -code error "malformatted verbatim line \"$line\"" - } - lappend lines $line - } else { - lappend lines [string range $line 1 end] - } - } - return [list verbatim $lines] - } - #index:* { - set type [string trim [string range $paragraph 7 end]] - if {![string length $type]} {set type medium} - return [list index $type] - } - #image:* { - return [list image [string range $paragraph 7 end]] - } - ---- { - return {separator} - } - } - - global ItemNoLeadRE ItemLeadRE ItemContRE - - # Hmm. Need to figure out if we've got a list item of some kind. - if {[regexp $ItemNoLeadRE $paragraph]} { - return [list ordinary [shortspc $paragraph]] - } - if {[regexp $ItemLeadRE $paragraph head continuation ? kind]} { - set content [string range $paragraph [string length $head] end] - set level [llength $continuation] - switch -glob -- $kind { - *: { - set kind [string trimright $kind ":"] - return [list description $kind $level [shortspc $content]] - } - *. { - set kind [string trimright $kind "."] - return [list enumeration $kind $level [shortspc $content]] - } - } - return [list bulleting $level [shortspc $content]] - } - if {[regexp $ItemContRE $paragraph head]} { - set content [string range $paragraph [string length $head] end] - return [list continuation [llength $head] [shortspc $content]] - } - return [list ordinary [shortspc $paragraph]] -} - -array set contentsCache {} -proc getTIPFileContents {filename} { - global contentsCache - if {[info exist contentsCache($filename)]} { - return $contentsCache($filename) - } - set f [open $filename r] - set content [read $f [file size $filename]] - close $f - set contentsCache($filename) $content -} -proc readTIPDetailsFromFile {filename} { - variable DEBUG_VERBATIM - if {![info exist DEBUG_VERBATIM]} { - set DEBUG_VERBATIM 0 - } - set pars [splitIntoParagraphs [getTIPFileContents $filename]] - foreach {headers title abstract} $pars {break} - set heads [verifyTIPheader [splitRFC822Header $headers]] - if {[string compare [intuitParagraphKind $title] {section Abstract 1}]} { - error "Must start with abstract..." - } - lappend heads Abstract [lindex [intuitParagraphKind $abstract] 1] - lappend heads RawAbstract $abstract - lappend heads Body [lrange $pars 3 end] -} -array set tipdetails {} -proc getTIPDetails {filename} { - global tipdetails contentsCache - if {![info exist tipdetails(time:$filename)] - || ([file mtime $filename] > $tipdetails(time:$filename))} { - set tipdetails(time:$filename) [file mtime $filename] - catch {unset contentsCache($filename)} - set tipdetails(file:$filename) [readTIPDetailsFromFile $filename] - } - return $tipdetails(file:$filename) -} -proc getTIPFilenames {} { - global DOCDIR FEATURE TESTINGTIP - cd $DOCDIR - set tips [lsort -dictionary [glob *.tip]] - # Assume the testing TIP (only visible when editing enabled) is at end! - if { - !$FEATURE(EDIT) && - ![string compare [lindex $tips end] ${TESTINGTIP}.tip] - } then { - # Don't remove TIP 10000 if editing is enabled. - set tips [lreplace $tips end end] - } - return $tips -} -proc foreachTIP {arrayname script} { - upvar 1 $arrayname ary - foreach file [getTIPFilenames] { - array set ary [getTIPDetails $file] - uplevel 1 $script - unset ary - } -} -proc foreachTIPreverse {arrayname script} { - upvar 1 $arrayname ary - set files [getTIPFilenames] - for {set idx [llength $files]} {[incr idx -1] >= 0} {} { - array set ary [getTIPDetails [lindex $files $idx]] - uplevel 1 $script - unset ary - } -} - -proc convert {in out {type html}} { - set cwd [pwd] - set document [formatTIPDocument [getTIPFileContents $in] $type] - - set fout [open [file join $cwd $out] w] - puts -nonewline $fout $document - flush $fout - close $fout -} - -proc formatTIPDocument {string {type html} args} { - global SRCDIR - set ns tip${type} - source $SRCDIR/$ns.tcl - - variable DEBUG_VERBATIM - if {![info exist DEBUG_VERBATIM]} { - set DEBUG_VERBATIM 0 - } - set pars [splitIntoParagraphs $string] - set heads [verifyTIPheader [splitRFC822Header [lindex $pars 0]]] - set par1 [intuitParagraphKind [lindex $pars 1]] - if {[string compare $par1 {section Abstract 1}]} { - array set h $heads - return -code error "TIP $h(TIP) must start with abstract..." - } - - global convert - set convert {} - proc ${ns}::puts {args} { - global convert - switch [llength $args] { - 2 {append convert [lindex $args 1]} - 1 {append convert [lindex $args 0] "\n"} - } - } - if {[llength $args]} { - ${ns}::generateDocument $heads [lrange $pars 1 end] $args - } else { - ${ns}::generateDocument $heads [lrange $pars 1 end] - } - - return $convert -} - -if {![info exist SRCDIR]} { - set SRCDIR [file join [pwd] [file dirname [info script]]] - source $SRCDIR/config.tcl - - append convertRE {^([0-9]+).} ([join $renderexts |]) {$} - if {[regexp $convertRE [lindex $argv 0] out id type]} { - catch { - set src [file join $DOCDIR $id.tip] - puts -nonewline "converting $src to $out..." - flush stdout - convert $src $out $type - puts " done" - exit - } - puts $errorInfo - exit 1 - } -} DELETED post.tcl Index: post.tcl ================================================================== --- post.tcl +++ /dev/null @@ -1,65 +0,0 @@ -# FILE: post.tcl -# -# Routines to process the HTTP POST method, gathering HTML form input -# values from stdin, and storing it in namespace variables post::* . - -namespace eval post { - variable operation edit - variable email "" - variable name "" -} - -proc post::UrlDecode {str} { - regsub -all {\+} $str { } str - regsub -all {[][\\\$]} $str {\\&} str - regsub -all {%([0-9a-fA-F][0-9a-fA-F])} $str {[format %c 0x\1]} str - set str [subst $str] - regsub -all "\r\n" $str "\n" str - return $str -} - -# Local variables in this proc have a leading underscore so they do -# not interfere with the namespace variables. -proc post::getVars {{env env}} { - upvar #0 $env _e - upvar #0 URI _URI - - if {![info exists _e(CONTENT_TYPE)]} { - generr "Bad Request" "the request $_e(REQUEST_METHOD) for URL\ - $_URI did not provide a Content-Type." {} 400 - } - if {![info exists _e(CONTENT_LENGTH)] - || ![regexp {^[0-9]+$} [string trim $_e(CONTENT_LENGTH)]]} { - generr "Bad Request" "the request $_e(REQUEST_METHOD) for URL\ - $_URI did not provide a valid Content-Length." {} 411 - } - if {[string compare application/x-www-form-urlencoded $_e(CONTENT_TYPE)]} { - generr "Unsupported Request" "the request $_e(REQUEST_METHOD) for URL\ - $_URI provided Content-Type '$_e(CONTENT_TYPE)' instead of \ - 'application/x-www-form-urlencoded'." {} 415 - } - set _query [read stdin $_e(CONTENT_LENGTH)] - foreach _def [split $_query &] { - set _pair [split $_def =] - if {[llength $_pair] != 2} { - generr "Bad Request" "the request $_e(REQUEST_METHOD) for URL\ - $_URI provided improperly encoded form data" {} 400 - } - set _varName [UrlDecode [lindex $_pair 0]] - if {[string match _* $_varName]} { - generr "Forbidden Request" "the request $_e(REQUEST_METHOD) for\ - URL $_URI provided form variables with leading underscores." \ - {} 403 - } - if {[regexp {[^a-zA-Z0-9_]} $_varName]} { - generr "Forbidden Request" "the request $_e(REQUEST_METHOD) for\ - URL $_URI provided form variables containing non-alphanumeric\ - characters." {} 403 - } - variable $_varName - set $_varName [UrlDecode [lindex $_pair 1]] - } - - # Disable multiple calls of this command - rename [lindex [info level 0] 0] {} -} DELETED postnews.tcl Index: postnews.tcl ================================================================== --- postnews.tcl +++ /dev/null @@ -1,192 +0,0 @@ -#! /bin/sh -#\ -exec tclsh "$0" ${1+"$@"} - -set SRCDIR [file join [pwd] [file dirname $argv0]] -source $SRCDIR/config.tcl -source $SRCDIR/parse.tcl -source $SRCDIR/md5.tcl -source $SRCDIR/base64.tcl -source $SRCDIR/post.tcl -source $SRCDIR/mail.tcl - -binary scan [binary format f [pid].[clock seconds]] I uniquePart - -proc MD5inB64 {str} { - return [B64encode [md5pure::md5 $str] 128] -} - -proc generateNewsMessage {tipnumber extra} { - global DOCDIR PUBLISHURL FEATURE FOOTERTEXT ENGINEURL TCLCOREMAIL - global opts uniquePart - set tipfile [file join $DOCDIR $tipnumber.tip] - set docurl $PUBLISHURL/$tipnumber.html - set editurl $PUBLISHURL/edit/$tipnumber - - puts stderr "Loading TIP from $tipfile" - array set h [getTIPDetails $tipfile] - set tip [getTIPFileContents $tipfile] - - puts stderr "Generating plain text body" - if {$FEATURE(EDIT_URL_IN_NEWS_MESSAGE)} { - set body [formatTIPDocument $tip txt URL $docurl WebEdit $editurl] - } else { - set body [formatTIPDocument $tip txt URL $docurl] - } - - puts stderr "Generating body md5 digest" - set digest [MD5inB64 $body] - - puts stderr "Generating headers" - append content \ - "MIME-Version: 1.0\n" \ - "Content-Type: text/plain; charset=iso-8859-1\n" \ - "Content-Transfer-Encoding: 8bit\n" \ - "Content-MD5: $digest\n" - append content [clock format [clock seconds] -gmt 1 -format \ - "Date: %a, %d %b %Y %H:%M:%S +0000\n"] - append content [format "Message-Id: \n" \ - $tipnumber $uniquePart [info hostname]] - if {[llength $extra]} { - append content "Subject: [join $extra] TIP #$h(TIP): $h(Title)\n" - } else { - append content "Subject: TIP #$h(TIP): $h(Title)\n" - } - regsub -all "\t" [lindex $h(Author) 0] " " a0 - regsub {^(.*[.].*[^ ]) +<(.+)>$} $a0 {"\1" <\2>} a0 - append content \ - "Sender: TIP Editor \n" \ - "From: [string trim $a0]\n" \ - "Errors-To: donal.fellows@man.ac.uk\n" - if {$opts(news)} { - append content \ - "Newsgroups: comp.lang.tcl,comp.lang.tcl.announce\n" \ - "To: tcl-announce@mitchell.org\n" \ - "Reply-To: [string trim $a0]\n" \ - "Followup-To: comp.lang.tcl\n" - # Some software seems to insist on sending email messages to - # me in response to TIPs; this is just about as bogus as you - # can get. However, mail in general provides no way to say - # that you want administrative stuff going to one address, - # and subject-matter related stuff going to another. This - # sucks... - ###append content "Reply-To: $TCLCOREMAIL\n" - set opts(news) 0 - } elseif {$opts(list)} { - append content \ - "To: $TCLCOREMAIL\n" \ - "Reply-To: $TCLCOREMAIL\n" - set opts(list) 0 - if {$opts(author)} { - set opts(author) 0 - foreach author $h(Author) { - regsub {^(.*[.].*[^ ]) +<(.+)>$} $author {"\1" <\2>} author - append content "Cc: $author\n" - } - } - foreach extraAddress $opts(extra) { - append content "Cc: $extraAddress\n" - } - set opts(extra) {} - } elseif {$opts(author)} { - set opts(author) 0 - foreach author $h(Author) { - regsub {^(.*[.].*[^ ]) +<(.+)>$} $author {"\1" <\2>} author - append content "To: $author\n" - } - foreach extraAddress $opts(extra) { - append content "Cc: $extraAddress\n" - } - set opts(extra) {} - } - append content \ - "Organization: Tcl Core Team\n" \ - "X-Generated-By: $FOOTERTEXT\n" \ - "X-Generator-Url: $ENGINEURL\n" - if {[info exist h(Keywords)]} { - append content "Keywords: [join $h(Keywords) {, }]\n" - } - append content "\n" $body - - puts stderr "Posting message" - return $content -} - -if {!$FEATURE(PUBLISHING)} { - puts stderr "Sorry, but this installation does not support\ - publishing of TIPs" - exit 1 -} - -proc preset {ary name value} { - upvar $ary a - if {![info exist a($name)]} { - set a($name) $value - } -} -proc shift {{n 1}} { - global argv - set shifted [lrange $argv 0 [expr $n-1]] - set argv [lrange $argv $n end] - return $shifted -} - -proc main {} { - global argc argv opts argv0 TCLCOREMAIL - if {$argc == 0} { - puts stderr "usage: [file tail $argv0] ?options? ?--? tipNumber" - puts stderr "Supported options are:" - puts stderr "\t-news\t Posts to comp.lang.tcl and comp.lang.tcl.announce" - puts stderr "\t-list\t Posts to $TCLCOREMAIL mailing list." - puts stderr "\t-author\t Sends a copy to the (first) author of the TIP." - puts stderr "\t-extra address" - puts stderr "\t\t Sends the publishing message to an extra email address" - puts stderr "\t\t (e.g. a mailing list where people have a special interest" - puts stderr "\t\t in the TIP.) Multiple extra email addresses can be" - puts stderr "\t\t specificied by using this option mulktiple times." - puts stderr "\t-test\t Prevent all posting/mailing and prints formatted on" - puts stderr "\t\t standard output (for debugging.)" - puts stderr "\t--\t Marks the end of the options." - exit - } - array set opts {} - while {[llength $argv]} { - switch -- [lindex $argv 0] { - -news {set opts(news) 1} - -list {set opts(list) 1} - -author {set opts(author) 1} - -test {set opts(test) 1} - -- {shift; break} - -extra { - shift - lappend opts(extra) [lindex $argv 0] - } - default {break} - } - shift - } - if {![array size opts]} { - array set opts { - news 1 list 1 author 1 test 0 extra {} - } - } else { - preset opts news 0 - preset opts list 0 - preset opts author 0 - preset opts test 0 - preset opts extra {} - } - - while {[lsearch [array get opts] 1] >= 0} { - set message [generateNewsMessage [lindex $argv 0] [lrange $argv 1 end]] - if {$opts(test)} { - puts $message - set opts(test) 0 - break - } else { - mail::mailsend $message 1 - } - } -} -main -exit DELETED quicktip.tcl Index: quicktip.tcl ================================================================== --- quicktip.tcl +++ /dev/null @@ -1,223 +0,0 @@ -#! /usr/local/bin/tclsh8.0 - -# Regular expressions - suitable for 8.0 as well as later. -set ws "\[ \t\n\]" -set ParSepRE "^$ws*$" -set ItemNoLeadRE "^\[^ \t>\]" -set ItemLeadRE "^$ws*((>$ws+)*)(\\*|\[0-9\]+\\.|\[^\t\n:\]+:)$ws" -set ItemContRE "^($ws+>)+$ws*" -set EmailRE {<([^<>@]+@[^<>@]+)>} -# It took lots of experiment to develop this next RE... -set URLRE {(https?|ftp|news(rc)?|mailto|gopher):[-A-Za-z0-9/_:.#+@?=&;~\\]+} - -# ---------------------------------------------------------------------- - -proc splitIntoParagraphs {string} { - global ParSepRE - set paragraphs {} - set current {} - foreach line [split $string "\n"] { - if {[regexp $ParSepRE $line]} { - # (VISUALLY) BLANK LINE = PARAGRAPH SEPARATOR - if {[string length $current]} { - lappend paragraphs [string trim $current "\n"] - set current {} - } - continue - } - append current "\n$line" - } - if {[string length $current]} { - lappend paragraphs [string trim $current "\n"] - } - return $paragraphs -} - -proc shortspc {string} { - global ws - regsub -all ${ws}+ $string " " string - return $string -} -proc intuitParagraphKind {paragraph} { - switch -glob -- $paragraph { - ~* { - set content [string range $paragraph 1 end] - return [list section [string trim [shortspc $content]]] - } - |* { - set lines {} - foreach line [split $paragraph "\n"] { - if {![string match |* $line]} { - return -code error "malformatted verbatim line \"$line\"" - } - lappend lines [string range $line 1 end] - } - return [list verbatim $lines] - } - #index:* { - set type [string trim [string range $paragraph 7 end]] - if {![string length $type]} {set type medium} - return [list index $type] - } - #image:* { - return [list image [string range $paragraph 7 end]] - } - ---- { - return {separator} - } - } - - global ItemNoLeadRE ItemLeadRE ItemContRE - - # Hmm. Need to figure out if we've got a list item of some kind. - if {[regexp $ItemNoLeadRE $paragraph]} { - return [list ordinary [shortspc $paragraph]] - } - if {[regexp $ItemLeadRE $paragraph head continuation ? kind]} { - set content [string range $paragraph [string length $head] end] - set level [llength $continuation] - switch -glob -- $kind { - *: { - set kind [string trimright $kind ":"] - return [list description $kind $level [shortspc $content]] - } - *. { - set kind [string trimright $kind "."] - return [list enumeration $kind $level [shortspc $content]] - } - } - return [list bulleting $level [shortspc $content]] - } - if {[regexp $ItemContRE $paragraph head]} { - set content [string range $paragraph [string length $head] end] - return [list continuation [llength $head] [shortspc $content]] - } - return [list ordinary [shortspc $paragraph]] -} - -# ---------------------------------------------------------------------- - -namespace eval tiphtml { - variable curlev -1 - variable contexts {} - proc enterlistcontext {level good bad1 bad2} { - variable curlev - variable contexts - if {$level > $curlev} { - incr curlev - lappend contexts "" - puts -nonewline "<$good compact>" - } - switch [lindex $contexts end] "" - "" { - puts -nonewline [lindex $contexts end] - puts -nonewline "<$good compact>" - set contexts [lreplace $contexts end end ""] - } - } - proc closecontext {{level -1}} { - variable curlev - variable contexts - while {$level < $curlev} { - incr curlev -1 - puts -nonewline [lindex $contexts end] - set contexts [lrange $contexts 0 [expr {[llength $contexts]-2}]] - } - } - proc quoteLiteral {string} { - # This would be better with [string map], but that's not in 8.0 - regsub -all & $string {\&} string - regsub -all < $string {\<} string - regsub -all > $string {\>} string - regsub -all \" $string {\"} string - return $string - } - - proc section {title} { - closecontext - puts "

    [quoteLiteral $title]

    " - } - proc ordinary {string} { - continuation -1 $string - } - proc bulleting {level body} { - closecontext $level - enterlistcontext $level ul ol dl - puts -nonewline "
  • " - continuation $level $body - } - proc description {tag level body} { - closecontext $level - enterlistcontext $level dl ol ul - puts -nonewline "
    $tag
    " - continuation $level $body - } - proc enumeration {tag level body} { - closecontext $level - enterlistcontext $level ol dl ul - if {$tag != 1} { - puts -nonewline "
  • " - } else { - puts -nonewline "
  • " - } - continuation $level $body - } - proc continuation {level body} { - global EmailRE URLRE - closecontext $level - regsub -all $EmailRE $body "\x81mailto:\\1\x82" body - set body [quoteLiteral $body] - - regsub -all $URLRE $body "&" body - - regsub -all {''(('?[^'])+)''} $body "\\1" body - regsub -all \x81 $body "\\<" body - regsub -all \x82 $body "\\>" body - variable curlev - if {$curlev==-1 && $level==1} { - puts "

    $body

    " - } else { - puts "

    $body

    " - } - } - proc separator {} { - closecontext - puts "
    " - } - proc verbatim {lines} { - puts "
    "
-	foreach line $lines {
-	    # HTML ignores formfeed chars, but we want to see them...
-	    regsub -all {} [quoteLiteral $line] "^L" line
-	    puts $line
-	}
-	puts -nonewline "
    " - } - - proc index {kind} { - closecontext - puts "

    Index\ - style \"$kind\" not yet supported!

    " - } - proc image {bodytext} { - closecontext - puts "

    Image\ - \"$bodytext\" not yet supported!

    " - } - proc generateHTMLPars {body} { - foreach par [splitIntoParagraphs $body] { - eval [intuitParagraphKind $par] - } - } -} - -# ---------------------------------------------------------------------- - -if {[llength $argv]} { - foreach arg $argv { - set f [open $arg] - tiphtml::generateHTMLPars [read $f] - close $f - } -} else { - tiphtml::generateHTMLPars [read stdin] -} DELETED stats.bybrowser.tcl Index: stats.bybrowser.tcl ================================================================== --- stats.bybrowser.tcl +++ /dev/null @@ -1,48 +0,0 @@ -#! /bin/sh -# \ -exec tclsh8.0 $0 ${1+"$@"} - -#awk '{$1=$2=$3=""; print}' ../TIP/log | sort | uniq -c | sort -n -#echo --------------------------- -#awk '{$1=$2=$3=""; print}' ../TIP/log | perl -ne 'do {print "IE\n"; next;} if /MSIE/; do {print "Netscape\n"; next;} if /Mozilla/; print "Other\n";' | sort | uniq -c | sort -n - -set SRCDIR [file join [pwd] [file dirname [info script]]] -source $SRCDIR/config.tcl - -set browsers {} -array set browsermap {} - -set f [open $LOGFILE r] -while {[gets $f line] >= 0} { - foreach {ip date name browser} [split $line "\t"] {break} - regsub -all {[ ]+} [string trim $browser] " " browser - append browsermap($browser) . -} -close $f - -foreach {name str} [array get browsermap] { - lappend browsers [list [string length $str] $name] -} -unset browsermap -array set browsermap {IE 0 Netscape 0 Other 0} - -foreach line [lsort -integer -index 0 $browsers] { - foreach {count browser} $line {} - puts [format "%6d %s" $count $browser] - switch -glob -- $browser { - *MSIE* {incr browsermap(IE) $count} - *Mozilla* {incr browsermap(Netscape) $count} - default {incr browsermap(Other) $count} - } -} -puts --------------------------- -set browsers {} -foreach {class count} [array get browsermap] { - lappend browsers [list $count $class] -} -foreach line [lsort -integer -index 0 $browsers] { - foreach {count class} $line {} - puts [format "%6d %s" $count $class] -} - -exit 0 DELETED stats.bydomain.tcl Index: stats.bydomain.tcl ================================================================== --- stats.bydomain.tcl +++ /dev/null @@ -1,51 +0,0 @@ -#! /bin/sh -# \ -exec tclsh8.0 $0 ${1+"$@"} - -set SRCDIR [file join [pwd] [file dirname [info script]]] -source $SRCDIR/config.tcl - -set ips {} -array set ipmap {} -set threshold 0 -if {[llength $argv]} { - set threshold [lindex $argv 0] -} - -set f [open $LOGFILE r] -while {[gets $f line] >= 0} { - foreach {ip date name browser} [split $line "\t"] {break} - append ipmap([string trim $ip]) . -} -close $f - -set NUMRE {([0-9]?[0-9]?[0-9])} -set DQRE "^$NUMRE\.$NUMRE\.$NUMRE\.$NUMRE$" - -foreach {ip str} [array get ipmap] { - set len [string length $str] - set domain numeric/unknown - if {$len > $threshold} { - set host $ip - catch { - set host [lindex [lindex [split [exec host $ip] "\n"] 0] 1] - if {![regexp $DQRE $host]||$a>255||$b>255||$c>255||$d>255} { - set domain [join [lrange [split $host .] 1 end] .] - } - } - } - append dommap($domain) $str -} -unset ipmap - -foreach {domain str} [array get dommap] { - lappend ips [list [string length $str] $domain] -} -unset dommap - -foreach line [lsort -integer -index 0 $ips] { - foreach {count domain} $line {} - puts [format "%6d %s" $count $domain] -} - -exit 0 DELETED stats.byfile.tcl Index: stats.byfile.tcl ================================================================== --- stats.byfile.tcl +++ /dev/null @@ -1,30 +0,0 @@ -#! /bin/sh -# \ -exec tclsh8.0 $0 ${1+"$@"} - -#awk '{print $3}' ../TIP/log | sort | uniq -c | sort -n - -set SRCDIR [file join [pwd] [file dirname [info script]]] -source $SRCDIR/config.tcl - -set files {} -array set filemap {} - -set f [open $LOGFILE r] -while {[gets $f line] >= 0} { - foreach {ip date name browser} [split $line "\t"] {break} - append filemap([string trim $name]) . -} -close $f - -foreach {name str} [array get filemap] { - lappend files [list [string length $str] $name] -} -unset filemap - -foreach line [lsort -integer -index 0 $files] { - foreach {count file} $line {} - puts [format "%6d %s" $count $file] -} - -exit 0 DELETED stats.byip.tcl Index: stats.byip.tcl ================================================================== --- stats.byip.tcl +++ /dev/null @@ -1,39 +0,0 @@ -#! /bin/sh -# \ -exec tclsh8.0 $0 ${1+"$@"} - -#awk '{print $1}' ../TIP/log | sort | uniq -c | sort -n - -set SRCDIR [file join [pwd] [file dirname [info script]]] -source $SRCDIR/config.tcl - -set ips {} -array set ipmap {} -set threshold 0 -if {[llength $argv]} { - set threshold [lindex $argv 0] -} - -set f [open $LOGFILE r] -while {[gets $f line] >= 0} { - foreach {ip date name browser} [split $line "\t"] {break} - append ipmap([string trim $ip]) . -} -close $f - -foreach {ip str} [array get ipmap] { - lappend ips [list [string length $str] $ip] -} -unset ipmap - -foreach line [lsort -integer -index 0 $ips] { - foreach {count host} $line {} - if {$count > $threshold} { - catch { - set host [lindex [lindex [split [exec host $host] "\n"] 0] 1] - } - } - puts [format "%6d %s" $count $host] -} - -exit 0 ADDED support/tipmode.el Index: support/tipmode.el ================================================================== --- /dev/null +++ support/tipmode.el @@ -0,0 +1,454 @@ +;;; tipmode.el --- A mode for editing Tcl Improvement Proposals. + +;; Copyright (C) 2000 Donal K. Fellows + +(defconst tip-mode-revision-string "$Id: tipmode.el,v 1.13 2004/08/09 22:15:14 dkf Exp $" + "Some CVS/RCS info relating to tipmode.el...") + +;(require 'text) ; text-mode always available? + +(defgroup tip nil "Major mode for editing Tcl Improvement Proposals." + :group 'tcl + :group 'text + :prefix "tip-") + +(defgroup tipface nil "Faces used when highlighting TIPs." + :group 'tip + :group 'faces) + +(defcustom tip-mode-hook nil + "Normal hook run when entering TIP mode." + :type 'hook + :group 'tip) + +(defcustom tip-skeleton-head + "TIP: ??? +Title: Title for Skeleton TIP +State: Draft +Type: Project +Tcl-Version: 9.0 +Vote: Pending +Post-History: " + "*A skeleton of a TIP header, minus certain derivable/computed fields." + :type 'string + :group 'tip) + +(defcustom tip-skeleton-body "~ Abstract + +A ''single'' paragraph, in third person voice, outlining what your TIP +is all about. + +~ Rationale + +Why is this TIP needed? + +~ Proposed Change + +What are you going to do? ''This need not include a patch during +initial discussion, and should not include a verbatim patch at all +(due to publishing restrictions.)'' + +~ Copyright + +This document has been placed in the public domain. +" "*A skeleton of a TIP body, a suitable place to start writing your own." + :type 'string + :group 'tip) + + + +(defvar tip-header-key-face 'tip-header-key-face + "Face name to use for keys in TIP headers.") +(defvar tip-header-value-face 'tip-header-value-face + "Face name to use for values in TIP headers.") +(defvar tip-verbatim-face 'tip-verbatim-face + "Face name to use for verbatim text in TIPs.") +(defvar tip-magic-paragraph-start-face 'tip-magic-paragraph-start-face + "Face name to use for symbol sequences that start specially +meaningful paragraphs in TIPs.") +(defvar tip-section-title-face 'tip-section-title-face + "Face name to use for section titles in TIPs.") +(defvar tip-magic-paragraph-info-face 'tip-magic-paragraph-info-face + "Face name to use for extra info that follow paragraph starts with +special meaning in TIPs.") +(defvar tip-list-start-face 'tip-list-start-face + "Face name to use for list item start sequences in TIPs.") +(defvar tip-uri-face 'tip-uri-face + "Face name to use for URIs in TIPs.") + +(defface tip-header-key-face ;copy of font-lock-builtin-face + '((((class grayscale) (background light)) (:foreground "LightGray" :bold t)) + (((class grayscale) (background dark)) (:foreground "DimGray" :bold t)) + (((class color) (background light)) (:foreground "Purple")) + (((class color) (background dark)) (:foreground "Cyan")) + (t (:bold t))) + "Face for highlighting keys in TIP headers." + :group 'tipface) +(defface tip-header-value-face ;copy of font-lock-function-name-face + '((((class color) (background light)) (:foreground "Blue")) + (((class color) (background dark)) (:foreground "LightSkyBlue")) + (t (:inverse-video t :bold t))) + "Face for highlighting values in TIP headers." + :group 'tipface) +(defface tip-verbatim-face ;copy of font-lock-string-face + '((((class grayscale) (background light)) (:foreground "DimGray" :italic t)) + (((class grayscale) (background dark)) (:foreground "LightGray" :italic t)) + (((class color) (background light)) (:foreground "RosyBrown")) + (((class color) (background dark)) (:foreground "LightSalmon")) + (t (:italic t))) + "Face for highlighting verbatim paragraphs in TIPs." + :group 'tipface) +(defface tip-magic-paragraph-start-face ;copy of font-lock-function-name-face + '((((class color) (background light)) (:foreground "Blue")) + (((class color) (background dark)) (:foreground "LightSkyBlue")) + (t (:inverse-video t :bold t))) + "Face for highlighting symbol sequences that start specially +meaningful paragraphs in TIPs." + :group 'tipface) +(defface tip-magic-paragraph-info-face ;copy of font-lock-variable-name-face + '((((class grayscale) (background light)) + (:foreground "Gray90" :bold t :italic t)) + (((class grayscale) (background dark)) + (:foreground "DimGray" :bold t :italic t)) + (((class color) (background light)) (:foreground "DarkGoldenrod")) + (((class color) (background dark)) (:foreground "LightGoldenrod")) + (t (:bold t :italic t))) + "Face for highlighting extra info that follow paragraph starts with +special meaning in TIPs." + :group 'tipface) +(defface tip-section-title-face ;copy of font-lock-constant-face + '((((class grayscale) (background light)) + (:foreground "LightGray" :bold t :underline t)) + (((class grayscale) (background dark)) + (:foreground "Gray50" :bold t :underline t)) + (((class color) (background light)) (:foreground "CadetBlue")) + (((class color) (background dark)) (:foreground "Aquamarine")) + (t (:bold t :underline t))) + "Face for highlighting section titles in TIPs." + :group 'tipface) +(defface tip-list-start-face ;copy of font-lock-function-name-face + '((((class color) (background light)) (:foreground "Blue")) + (((class color) (background dark)) (:foreground "LightSkyBlue")) + (t (:inverse-video t :bold t))) + "Face for highlighting list item start sequences in TIPs." + :group 'tipface) +(defface tip-uri-face + '((t (:underline t))) + "Face for highlighting URIs in TIPs." + :group 'tipface) + +(defvar tip-mode-syntax-table (make-syntax-table text-mode-syntax-table) + "Syntax table used while in TIP mode.") + +(defvar tip-mode-abbrev-table nil + "Abbrev table used while in TIP mode.") +(define-abbrev-table 'tip-mode-abbrev-table ()) + +(defvar tip-mode-map () "Keymap for TIP mode.") +(if tip-mode-map + () + (setq tip-mode-map (copy-keymap text-mode-map)) + (let ((map (make-sparse-keymap))) + (define-key map "s" 'tip-insert-section-header) + (define-key map "i" 'tip-insert-image) + (define-key map "x" 'tip-insert-index) + (define-key map "v" 'tip-verbatim-region) + (define-key map "\C-c" 'tip-insert-skeleton) + (define-key map "p" 'tip-check-spelling) + (define-key map "h" 'tip-verify-headers) + (define-key tip-mode-map "\C-c" map) + (define-key tip-mode-map [menu-bar] (make-sparse-keymap)) + (define-key tip-mode-map [menu-bar tip] + (cons "TIP" (make-sparse-keymap "TIP"))) + (define-key tip-mode-map [menu-bar tip verbatim-region] + '("Verbatim Region" . tip-verbatim-region)) + (define-key tip-mode-map [menu-bar tip insert-image] + '("Insert Image" . tip-insert-image)) + (define-key tip-mode-map [menu-bar tip insert-index] + '("Insert Index" . tip-insert-index)) + (define-key tip-mode-map [menu-bar tip insert-section-header] + '("Insert Section" . tip-insert-section-header)) + (define-key tip-mode-map [menu-bar tip check-spelling] + '("Check Spelling" . tip-check-spelling)) + (define-key tip-mode-map [menu-bar tip verify-headers] + '("Verify Headers" . tip-verify-headers)) + (define-key tip-mode-map [menu-bar tip insert-skeleton] + '("Insert Skeleton" . tip-insert-skeleton)) + (put 'tip-verbatim-region 'menu-enable 'mark-active) + )) + +(defvar tip-font-lock-keywords + '(("^\\(#i\\(ndex\\|mage\\):\\)\\(\\S-*\\)" + (1 tip-magic-paragraph-start-face) (3 tip-magic-paragraph-info-face)) + ("^\\(~\\)\\s-*\\(\\S-.*\\)" + (1 tip-magic-paragraph-start-face) (2 tip-section-title-face)) + ("^\\(\\(T\\(IP\\|itle\\|ype\\)\\|\\(Tcl-\\)?Version\\|Author\\|State\\|Vote\\(-By\\|s-\\(For\\|A\\(gainst\\|bstained\\)\\)\\)?\\|Created\\|Post-History\\|Obsolete\\(s\\|d-By\\)\\|Keywords\\|Discussions-To\\):\\)[ \t]*\\(\\(\\S-.*\\)?\\)" + (1 tip-header-key-face) (6 tip-header-value-face)) + ("^|.*" (0 tip-verbatim-face)) + ("^[ \t]+\\(\\(>\\s-+\\)*\\([*>]\\|[0-9]+.\\|.*:\\)\\)" + (1 tip-list-start-face)) + ("\\(https?\\|ftp\\|news\\|newsrc\\|mailto\\|gopher\\):\\([-a-zA-Z0-9.]+:[0-9]+/\\)?[-A-Za-z0-9/_.%#+@?=&;~]+" + (0 tip-uri-face)) + ("tip:[0-9]+" (0 tip-uri-face)) + ("<\\(\\S-+@\\S-+\\)>" (1 tip-uri-face))) + "Default expressions to highlight in TIP mode.") +(defvar tip-font-lock-defaults + '(tip-font-lock-keywords t nil nil mark-paragraph)) +(defvar tip-imenu-generic-expression + '((nil "^~\\s-*\\(.*\\)" 1))) + +;;;###autoload +(defun tip-mode () + "Major mode for editing TIP documents. +The following keys are bound: +\\{tip-mode-map} +" + (interactive) + (text-mode) + (set-syntax-table tip-mode-syntax-table) + (use-local-map tip-mode-map) + (make-local-variable 'imenu-generic-expression) + (make-local-variable 'font-lock-defaults) + (setq major-mode 'tip-mode + mode-name "TIP" + local-abbrev-table tip-mode-abbrev-table + imenu-generic-expression tip-imenu-generic-expression + font-lock-defaults tip-font-lock-defaults + ) + (imenu-add-to-menubar "Sections") + (run-hooks 'tip-mode-hook) + ) + +(defun tip-insert-paragraph (string) + (or (bolp) (insert "\n")) + (insert "\n" string "\n") + (or (eolp) (insert "\n"))) +(defun tip-insert-section-header (title) + "Insert a section header paragraph." + (interactive "*MSection title:") + (tip-insert-paragraph (format "~ %s" title))) +(defun tip-insert-index (kind) + "Insert an index paragraph." + (interactive (list (completing-read "Index kind: " + [short medium long] nil t nil + nil "medium"))) + (tip-insert-paragraph (format "#index:%s" kind))) +(defun tip-insert-image (url caption) + "Insert an image paragraph." + (interactive "*sURL to reference: \nMCaption for image: ") + (tip-insert-paragraph (format "#image:%s %s" url caption))) +(defun tip-verbatim-region (from to) + "Makes the lines including the region into verbatim text." + (interactive "*r") + (let (fm tm) + (goto-char from) + (beginning-of-line) + (setq fm (point-marker)) + (goto-char to) + (or (bolp) (end-of-line)) + (setq tm (point-marker)) + (untabify fm tm) + (goto-char fm) + (while (< (point) tm) + (beginning-of-line) + (insert "|") + (forward-line)) + (set-marker fm nil) + (set-marker tm nil))) + +(defun tip-insert-skeleton () + "Insert a skeleton TIP into the current buffer. +This allows people to get started writing a TIP much more rapidly." + (interactive) + (insert tip-skeleton-head) + (insert (format "%cVersion:%c%cRevision%c" 10 9 36 36)) + (insert (format "%cAuthor:%c%c%s <%s>" + 10 9 9 (user-full-name) user-mail-address)) + (insert (format-time-string "%nCreated:%t%d-%b-%Y")) + (insert (format "%c%c" 10 10)) + (insert tip-skeleton-body)) + +;; Copied and adapted shamelessly from ispell.el! +(defun tip-check-spelling () + (interactive) + (save-excursion + (goto-char (point-min)) + (let* ((end-of-headers ; Start of body. + (copy-marker + (or (re-search-forward "^$" nil t) + (point-min)))) + (limit (copy-marker ; End of region we will spell check. + (cond + ((not ispell-message-text-end) (point-max)) + ((char-or-string-p ispell-message-text-end) + (if (re-search-forward ispell-message-text-end nil t) + (match-beginning 0) + (point-max))) + (t (min (point-max) (funcall + ispell-message-text-end)))))) + (ispell-skip-region-alist + (cons (list "^|" (function forward-line)) + ispell-skip-region-alist)) + (old-case-fold-search case-fold-search) + (case-fold-search t) + (dictionary-alist ispell-message-dictionary-alist) + (ispell-checking-message t)) + (or (local-variable-p 'ispell-local-dictionary (current-buffer)) + (while dictionary-alist + (goto-char (point-min)) + (if (re-search-forward (car (car dictionary-alist)) + end-of-headers t) + (setq ispell-local-dictionary (cdr (car dictionary-alist)) + dictionary-alist nil) + (setq dictionary-alist (cdr dictionary-alist))))) + (unwind-protect + (progn + ;; Spell check any Title: or Keywords: + (goto-char (point-min)) + (while (re-search-forward "^\\(Title\\|Keywords\\): *" end-of-headers t) + (progn + (goto-char (match-end 0)) + (let ((case-fold-search old-case-fold-search)) + (ispell-region (point) + (progn ;Tab-initiated continuation lns. + (end-of-line) + (while (looking-at "\n[ \t]") + (end-of-line 2)) + (point)))))) + (goto-char end-of-headers) + (forward-line 1) + (ispell-region (point) limit)) + (set-marker end-of-headers nil) + (set-marker limit nil))))) + +(defconst tip-verify-states-re + "^\\(Draft\\|Accepted\\|Deferred\\|Final\\|Active\\|Rejected\\|Withdrawn\\)$" + "Regexp matching the acceptable values for the State: header field.") +(defconst tip-verify-types-re + "^\\(Project\\|Process\\|Inform.*\\)$" + "Regexp matching the acceptable values for the Type: header field.") +(defconst tip-verify-tclver-re + "^[0-9]+\\.[0-9]+\\([.ab][0-9]+\\)?$" + "Regexp matching the acceptable values for the Tcl-Version: header field.") +(defconst tip-verify-vote-re + "^\\(Pending\\|In progress\\|Done\\|No voting\\)$" + "Regexp matching the acceptable values for the Vote: header field.") +(defconst tip-verify-created-re + "^[0-9][0-9]-\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct\\|Nov\\|Dec\\)-20[0-9][0-9]$" + "Regexp matching the acceptable values for the Created: header field.") +(defconst tip-verify-author-re + "^.+ <.+@.+>$" + "Regexp matching the acceptable values for the Author: header field.") + +(defconst tip-header-matcher-alist + (list '("TIP" . "^[0-9]+$") + '("Title" . ".") + '("Version" . "^\$.+\$$") + (cons "State" tip-verify-states-re) + (cons "Type" tip-verify-types-re) + (cons "Tcl-Version" tip-verify-tclver-re) + (cons "Vote" tip-verify-vote-re) + (cons "Created" tip-verify-created-re) + (cons "Author" tip-verify-author-re) + '("Obsoletes" . "^[0-9]_$") + '("Obsoleted-By" . "^[0-9]_$") + '("Post-History" . ".*") + '("Discussions-To" . ".+") + '("Keywords" . ".+") + '("Vote-By" . ".+") + '("Votes-For" . ".+") + '("Votes-Against" . ".+") + '("Votes-Abstained" . ".+")) + "Alist of matchers for each of the legal TIP headers.") + +(defun tip-verify-headers () + "Perform a basic verification check on the TIP headers." + (interactive) + (save-excursion + (goto-char (point-min)) + (let ((headers) + (end-of-headers ; Start of body. + (copy-marker + (or (re-search-forward "^$" nil t) + (point-min))))) + (goto-char (point-min)) + (while (re-search-forward "^\\([-a-zA-Z]+\\):[ \t]*\\(.*\\)" + end-of-headers t) + (let* ((key (match-string 1)) + (body (match-string 2)) + (next (match-end 0)) + (re (assoc key tip-header-matcher-alist))) + (cond + ((not re) (error "Unknown header '%s:'" key)) + ((string-match (cdr re) body) + (setq headers (cons (cons key body) headers))) + (t (error "Illegal header '%s: %s'" key body))) + (goto-char next))) + (or (assoc "TIP" headers) (error "Missing header 'TIP:'")) + (or (assoc "Title" headers) (error "Missing header 'Title:'")) + (or (assoc "Version" headers) (error "Missing header 'Version:'")) + (or (assoc "State" headers) (error "Missing header 'State:'")) + (or (assoc "Type" headers) (error "Missing header 'Type:'")) + (or (assoc "Vote" headers) (error "Missing header 'Vote:'")) + (or (assoc "Created" headers) (error "Missing header 'Created:'")) + (or (assoc "Author" headers) (error "Missing header 'Author:'")) + (or (assoc "Post-History" headers) (error "Missing header 'Post-History:'")) + (let ((project (equal "Project" (cdr (assoc "Type" headers)))) + (tcl-version (assoc "Tcl-Version" headers))) + (if (and (not project) tcl-version) + (error "Can only have 'Tcl-Version:' header in Project TIPs")) + (if (and project (not tcl-version)) + (error "Must have 'Tcl-Version:' header in Project TIPs"))) + (message "TIP headers seem OK")))) + +;; Arrange for the mode to become associated with all buffers whose +;; filenames end in .tip, unless this has been done already... + +(if (assoc "\\.tip\\'" auto-mode-alist) () + (setq auto-mode-alist (cons '("\\.tip\\'" . tip-mode) auto-mode-alist))) +(message "%s" tip-mode-revision-string) + +(provide 'tipmode) + +;; $Log: tipmode.el,v $ +;; Revision 1.13 2004/08/09 22:15:14 dkf +;; Extend support for the new headers to the Emacs support +;; +;; Revision 1.12 2003/08/15 08:11:46 dkf +;; Omitted the Deferred state from the State: header checking RE. D'oh! +;; +;; Revision 1.11 2002/02/20 09:21:06 dkf +;; URLs can contain '%' so add it to match set. +;; +;; Revision 1.10 2002/01/10 11:57:11 dkf +;; Now have correctly functioning TIP header verifier. +;; +;; Revision 1.9 2001/12/18 14:12:14 dkf +;; More advanced online searching and some verification ability in the emacs mode +;; +;; Revision 1.8 2001/09/04 09:34:03 dkf +;; Substantive enhancement to tipmode.el (spelling+menu) +;; +;; Revision 1.7 2001/03/09 14:26:51 dkf +;; Supported https URLs and added a skeleton TIP generation function. +;; +;; Revision 1.6 2000/12/01 10:56:50 dkf +;; Improved autoloading. +;; +;; Revision 1.5 2000/11/21 15:25:29 dkf +;; Added a batch of "useful" editing commands. +;; +;; Revision 1.4 2000/11/21 10:25:54 dkf +;; Improved highlight regexps. +;; +;; Revision 1.3 2000/11/17 15:11:16 dkf +;; Improved support for other people's use and removed a stupid +;; font-definition bug. +;; +;; Revision 1.2 2000/11/15 14:17:07 dkf +;; Bugfixes... +;; +;; Revision 1.1 2000/11/15 11:49:51 dkf +;; Tweaked the LaTeX generator to remind people to get the accompanying +;; images, and added an emacs mode for editing TIPs. +;; DELETED tip.tcl Index: tip.tcl ================================================================== --- tip.tcl +++ /dev/null @@ -1,686 +0,0 @@ -#! /usr/local/bin/tclsh8.0 - -set ThisFilename [file join [pwd] [info script]] -while {![string compare [file type $ThisFilename] link]} { - # This is a symlink! - set ThisFilename [file join [file dirname $ThisFilename] \ - [file readlink $ThisFilename]] -} -set SRCDIR [file dirname $ThisFilename] -source $SRCDIR/config.tcl - -# This is *not* configurable because changing it can require many other -# changes to be made throughout the rest of the TIP suite. It is also -# not used outside this file. -set DOCTYPE "" -set DOCTYPE_FRAMES "" - -# Get the time when a file was last modified, in the format used by -# webservers (apparently.) -proc lastModTime {filename} { - # Removed day-of-week spec (which is written in by the - # webserver instead) but am not using %T since that is - # not universally supported - DKF - return [clock format [file mtime $filename] \ - -format "%d %B %Y %H:%M:%S GMT" -gmt 1] -} -# MH recommends a different format for Expires headers - DGP -proc expireTime {filename} { - # %T -> %H:%M:%S (see above) DKF - return [clock format [file mtime $filename] \ - -format "%a, %d %b %Y %H:%M:%S GMT" -gmt 1] -} - -proc gendoc {filename kind} { - global contenttypes - - # Head off the most common kind of "probing" error - if {![file readable $filename]} { - return -code error "File unreadable or non-existant" - } - - set f [open $filename r] - set d [read $f [file size $filename]] - close $f - - if {![string compare $kind .htm]} { - set kind .html - } - set data [formatTIPDocument $d [string trim $kind .]] - array set info [getTIPDetails $filename] - - puts "Content-Type: $contenttypes($kind)" - if {[info exist info(Keywords)]} { - puts "Keywords: [file join $info(Keywords) {, }]" - } - # Assume we can get away with this... - puts "Content-Length: [string length $data]" - # Active TIPs must always be regenerated from source, so we cannot - # supply a date of last modification. This is because they might - # format differently despite the source remaining unchanged. - if {[string compare $info(State) Active]} { - puts "Last-Modified: [lastModTime $filename]" - puts "Expires: [expireTime $filename]" - puts "Cache-Control: no-cache, must-revalidate" - puts "Pragma: no-cache" - } - puts "" - puts -nonewline $data -} - -proc transferraw {filename kind} { - global contenttypes - - # Head off the most common kind of "probing" error - if {![file readable $filename]} { - return -code error "File unreadable or non-existant" - } - - set f [open $filename r] - fconfigure $f -translation binary - puts "Content-Type: $contenttypes($kind)" - puts "Content-Length: [file size $filename]" - puts "Last-Modified: [lastModTime $filename]" - puts "" - fconfigure stdout -translation binary - fcopy $f stdout - flush stdout - fconfigure stdout -translation auto - close $f -} - -proc generr {title body {pfmt {}} {rcode 404} {errcode NONE}} { - global env BASETARG BASEURL CSSURL ICONURL URI DOCTYPE - - set title "ERROR: $title" - - fconfigure stdout -translation auto - - puts "Content-Type: text/html; charset=iso-8859-1" - puts "Response-Code: $rcode" - puts "" - puts $DOCTYPE - puts "$title" - puts "" - puts "" - puts "" - puts "" - puts "" - puts "" - puts "

    $title

    " - puts "

    An error occurred when serving $URI to you\ - because $body.

    " - if {[info exist env(HTTP_REFERER)]} { - puts "

    You might wish to inform the author of the\ - referring page.

    " - } - if {[string length $pfmt]} { - puts "

    Debugging Info:

    "
-	regsub -all & $pfmt {\&} pfmt
-	regsub -all < $pfmt {\<}  pfmt
-	regsub -all > $pfmt {\>}  pfmt
-	puts "$pfmt"
-	puts -nonewline "
    " - if {[string compare $errcode NONE]} { - regsub -all & $errcode {\&} errcode - regsub -all < $errcode {\<} errcode - regsub -all > $errcode {\>} errcode - puts "

    Error Code Trace:

    $errcode

    " - } - } - basicHTMLfooter - exit -} - - -proc serveFile {filename} { - global renderable DOCDIR errorInfo contenttypes - set ext [file extension $filename] - set filename [file join $DOCDIR [file tail $filename]] - if {![info exist contenttypes($ext)]} { - generr "Data unservable" \ - "that view of the document is not known and/or supported" - } - # At this point, if the working directory $DOCDIR hasn't been - # configured to get automatic updates on each commit, then a - # 'cvs update' on $filename should be done here. A 'cvs update' - # with every web hit would be very inefficient, so set up the - # automatic updates as indicated in config.tcl. - # - # If you're operating read-only, you can get away with using cron - # to run 'cvs update' instead and take whatever lag you are - # prepared to tolerate as a given... - if {[lsearch -exact $renderable $ext] >= 0} { - set filename [file rootname $filename].tip - gendoc $filename $ext - } else { - transferraw $filename $ext - } - exit -} - -proc processCGIOptions {{env env}} { # easier to test! - upvar #0 $env e - global URI SRCDIR FEATURE - global bodyURL indexType orderingColumn searchTerm searchArea - global revision0 revision1 revision2 cookie - global searchLocus searchAuthor searchDate searchDateRelation searchSort - global mailName mailUser mailSys mailTipNum - - set URI http://$e(SERVER_NAME) - if {$e(SERVER_PORT) != 80} { - append URI : $e(SERVER_PORT) - } - append URI $e(REQUEST_URI) - - if {[info exist e(HTTP_COOKIE)]} { - foreach keyval [split $e(HTTP_COOKIE) ";"] { - regexp { *([^=]+)=(.*)} $keyval -> key val - set cookie($key) $val - } - } - - switch -- $e(REQUEST_METHOD) { - GET - HEAD { - # these are OK - } - POST { - if {!$FEATURE(EDIT) && [info exist e(QUERY_STRING)]} { - switch -glob -- $e(QUERY_STRING) { - /edit/* { - generr "Unknown Request" "the request\ - $e(REQUEST_METHOD) for URL $URI is not\ - supported for that resource" {} 403 - } - } - } - source $SRCDIR/post.tcl - post::getVars $env - } - default { - generr "Unknown Request" "the request $e(REQUEST_METHOD)\ - for URL $URI is not supported for that resource" {} 403 - } - } - - array set query { - body 1.html - type * - sort none - search "" - where "" - cmpa 1.1 - cmpb 1.1 - ver NONE - locus "" - daterel "" - author "" - sortby TIP - day "" - month "" - year "" - name "" - user foobar - sys some.where - tipnum 10000 - } - array set multiple { - locus 1 - } - if {[info exist e(QUERY_STRING)]&&[string length $e(QUERY_STRING)]} { - foreach qs [split $e(QUERY_STRING) ,&] { - if { - ![regexp {^(.*)=(.*)$} $qs -> key value] || - ![info exist query($key)] - } then { - generr "Unknown URI" \ - "the uri $URI is not found on this server" - } - # Decode arguments - regsub -all {\+} $value " " value - regsub -all {[]${}\\[]} $value {\\&} value - regsub -all {%([0-9A-Fa-f][0-9A-Fa-f])} $value \ - {[format %c 0x\1]} value - if {[info exist multiple($key)]} { - lappend query($key) [subst $value] - } else { - set query($key) [subst $value] - } - } - } - - set bodyURL 1.html - set indexType * - set orderingColumn -1 - set searchTerm "" - set searchArea 0 - set revision0 NONE - set revision1 1.1 - set revision2 1.1 - - if { - ![info exist e(PATH_INFO)] || - ![string length $e(PATH_INFO)] || - [string match / $e(PATH_INFO)] - } then { - set bodyURL $query(body) - return /index.html - } - - set indexType $query(type) - set orderingColumn $query(sort) - set searchTerm $query(search) - set searchArea [string match Also* $query(where)] - set searchLocus [lsort $query(locus)] - set searchAuthor $query(author) - set searchSort $query(sortby) - if {[lsearch -exact $query(locus) created]} { - set searchDate $query(day)-$query(month)-$query(year) - set searchDateRelation $query(daterel) - } else { - set searchDate "" - set searchDateRelation "" - } - set revision0 $query(ver) - set revision1 $query(cmpa) - set revision2 $query(cmpb) - set mailName $query(name) - set mailUser $query(user) - set mailSys $query(sys) - set mailTipNum $query(tipnum) - set path $e(PATH_INFO) - if {![string length [file extension $path]]} { - append path .html - } - - return $path -} - -proc basicHTMLfooter {} { - global TCLLOGOURL TCLLOGOX TCLLOGOY FOOTERTEXT - puts "
    \"Powered
    $FOOTERTEXT
    " -} - -proc serveFrameset {body} { - global BASEURL DOCTYPE_FRAMES ICONURL - puts "Content-Type: text/html; charset=iso-8859-1" - puts "" - puts $DOCTYPE_FRAMES - puts "TIP Document Collection" - puts "" - puts "" - puts "" - puts "" - puts "" - puts "" - puts "<p align=\"justify\">Oh dear! Your browser don't seem\ - to support frames; perhaps you might wish to visit the\ - <a href=\"1.html\">TIP index</a> by way of consolation?\ - </p>" - puts "" - exit -} - -proc serveIndex {kind type} { - global BASEURL CSSURL ICONURL SRCDIR ENGINEURL DOCTYPE - puts "Content-Type: text/html; charset=iso-8859-1" - puts "" - puts $DOCTYPE - puts "TIP Index" - puts "" - puts "" - puts "" - puts "" - puts "" - puts "" - source $SRCDIR/tiphtml.tcl - tiphtml::index $kind hardError $type - puts "
    " - puts "

    The TIP archive is available by anonymous\ - CVS, and this TIP Rendering\ - engine is available online too.

    " - puts "

    \"Valid

    " - exit -} - -proc serveTclIndex {} { - puts "Content-Type: text/plain" - puts "" - set outerlist {} - foreachTIP h { - set l {} - foreach field { - TIP Type State Vote Title Created Author Version - Tcl-Version Keywords Obsoletes Obsoleted-By - Vote-By Voted-For Voted-Against Voted-Abstained - Abstract - } { - if {[info exist h($field)]} { - lappend l $field $h($field) - } - } - lappend outerlist $l - } - puts $outerlist - exit -} - -proc serveSearch {searchTerm lookInBodies} { - global BASEURL CSSURL ICONURL SRCDIR ENGINEURL DOCTYPE - source $SRCDIR/tiphtml.tcl - - puts "Content-Type: text/html; charset=iso-8859-1" - puts "" - puts $DOCTYPE - puts "Searching for\ - [tiphtml::quoteLiteral $searchTerm]" - puts "" - puts "" - puts "" - puts "" - puts "" - puts "" - if {[string length $searchTerm]} { - tiphtml::longidx * $searchTerm $lookInBodies - puts -nonewline "
    " - } - puts "
    Search for: 
     Advanced Search

    " - basicHTMLfooter - exit -} - -proc optMenu {var default args} { - set s "" -} -proc advancedSearch {} { - global BASEURL CSSURL ICONURL SRCDIR ENGINEURL DOCTYPE - source $SRCDIR/tiphtml.tcl - - puts "Content-Type: text/html; charset=iso-8859-1" - puts "" - puts $DOCTYPE - puts "Advanced Search" - puts "" - puts "" - puts "" - puts "" - puts "" - puts "" - puts "

    Advanced Search of TIP Archive

    Criteria:
    Search for in\ - Titles Keywords Abstracts Bodies
    " - puts " and by an author whose name or email address includes\ - the string:
    " - puts " and created [optMenu daterel on before after] the date\ - [optMenu day 01 02 03 04 05 06 07 08 09 10 11 12 13 14 15 16 17\ - 18 19 20 21 22 23 24 25 26 27 28 29 30 31]-[optMenu month Jan Feb\ - Mar Apr May Jun Jul Aug Sep Oct Nov Dec]-[optMenu year 2000 2001\ - 2002 2003 2004 2005]

    " - puts "

    Options:
    \ - [srchCB locus nofinal {Ignore Final TIPs}]\ - [srchCB locus nodraft {Ignore Draft TIPs}]\ - [srchCB locus project {Ignore Non-Project TIPs}]\ - [srchCB locus noreject {Ignore Rejected and Withdrawn TIPs}]

    " - puts "

    Sort result:
    Series ID Title State Type Voting Status" - basicHTMLfooter - exit -} -proc srchCB {name value label} { - regsub -all " " $label {\ } label - format " %s" \ - $name $value $label -} -proc serveSearch2 {locus pat1 pat2 date daterel order} { - global BASEURL CSSURL ICONURL SRCDIR ENGINEURL DOCTYPE - source $SRCDIR/tiphtml.tcl - - puts "Content-Type: text/html; charset=iso-8859-1" - puts "" - puts $DOCTYPE - puts "Results of Advanced Search" - puts "" - puts "" - puts "" - puts "" - puts "" - puts "" - tiphtml::longidx2 $locus $pat1 $pat2 $date $daterel $order - puts -nonewline "

    " - puts "
    Search for: 

    " - basicHTMLfooter - exit -} - -proc serveHistory {tipnumber} { - global BASEURL CSSURL ICONURL SRCDIR ENGINEURL EDITDIR DOCDIR DOCTYPE - set EDITDIR $DOCDIR - source $SRCDIR/history.tcl - - if {![regexp {^[0-9]+$} $tipnumber]} { - generr "Unknown TIP number" "TIPs must be numbered" - } - set leh [history::fmtlogentries $tipnumber] - - puts "Content-Type: text/html; charset=iso-8859-1" - puts "" - puts $DOCTYPE - puts "CVS History for TIP #$tipnumber" - puts "" - puts "" - puts "" - puts "" - puts "" - puts "" - puts "

    CVS History for TIP #$tipnumber

    " - - puts "
    $leh
    " - - basicHTMLfooter - exit -} - -proc serveDiff {tipnumber revision1 revision2} { - global BASEURL CSSURL ICONURL SRCDIR ENGINEURL EDITDIR DOCDIR DOCTYPE - set EDITDIR $DOCDIR - source $SRCDIR/history.tcl - - if {![regexp {^[0-9]+$} $tipnumber]} { - generr "Unknown TIP number" "TIPs must be numbered" - } - set dlh [history::fmtdifflines $tipnumber $revision1 $revision2] - - puts "Content-Type: text/html; charset=iso-8859-1" - puts "" - puts $DOCTYPE - puts "Comparing version $revision1 and $revision2\ - for TIP #$tipnumber" - puts "" - puts "" - puts "" - puts "" - puts "" - puts "" - puts "

    Comparing version $revision1 and $revision2 for\ - TIP #$tipnumber

    " - variable history::addbg - variable history::delbg - puts "

    Note that these changes are shown as applied to the source\ - document, and not as applied to the rendering into any\ - particular display format. Added lines are highlighted like this, and\ - deleted lines are\ - highlighted like this.

    " - - puts $dlh - - basicHTMLfooter - exit -} - -proc serveRevision {tipnumber version} { - global EDITDIR DOCDIR SRCDIR - set EDITDIR $DOCDIR - source $SRCDIR/history.tcl - - if {![regexp {^[0-9]+$} $tipnumber]} { - generr "Unknown TIP number" "TIPs must be numbered" - } - if {![regexp {^[0-9]+(\.[0-9]+)+$} $version]} { - generr "Unknown revision" "this server will not retrieve TIPs by tags" - } - set content [history::fmtrevision $tipnumber $version] - puts "Content-Type: text/html; charset=iso-8859-1" - puts "Content-Length: [string length $content]" - puts "" - puts $content - exit -} - -proc logAccess {what} { - global env LOGFILE - set RA ?.?.?.? - set UA ? - catch {set RA $env(REMOTE_ADDR)} - catch {set UA $env(HTTP_USER_AGENT)} - if {[catch {set f [open $LOGFILE a]}]} {return} - puts $f [format "%-15s\t%-10d\t%-15s\t%s" $RA [clock seconds] $what $UA] - flush $f - close $f -} - -catch { - if {[catch { - source $SRCDIR/parse.tcl - - set what [processCGIOptions] - logAccess $what - if {[info exist cookie(chongqid)]} { - generr "Temporary access problem" \ - "Temporary access problem detected; do try later." 402 - } - switch -glob -- $what { - / - /index.html { - set cmd [list serveFrameset $bodyURL] - } - /tclIndex.txt { - set cmd serveTclIndex - } - /short.html - /medium.html - /long.html { - set cmd [list serveIndex \ - [file rootname [file tail $what]] $indexType ] - } - /search.html { - set cmd [list serveSearch $searchTerm $searchArea] - } - /advancedsearch.html { - set cmd [list advancedSearch] - } - /advancedsearchresults.html { - set cmd [list serveSearch2 $searchLocus $searchTerm \ - $searchAuthor $searchDate $searchDateRelation \ - $searchSort] - } - /edit/* { - if {!$FEATURE(EDIT)} { - generr "Feature Not Supported" \ - "editing is not supported on this server" - } - source $SRCDIR/edit.tcl - set cmd [list \ - editTIP [file rootname [string range $what 6 end]] ] - } - /compare/* { - if {0&!$FEATURE(CVSWEB)} { - generr "Feature Not Supported" "CVS history inspection\ - is not supported on this server" - } - set cmd [list serveDiff \ - [file rootname [string range $what 9 end]] \ - $revision1 $revision2] - } - /history/* { - if {0&!$FEATURE(CVSWEB)} { - generr "Feature Not Supported" "CVS history inspection\ - is not supported on this server" - } - set cmd [list serveHistory \ - [file rootname [string range $what 9 end]]] - } - /view/* { - if {0&!$FEATURE(CVSWEB)} { - generr "Feature Not Supported" "CVS history inspection\ - is not supported on this server" - } - set cmd [list serveRevision \ - [file rootname [string range $what 6 end]] \ - $revision0] - } - /mail.html { - source $SRCDIR/mail.tcl - set cmd [list mail::mailform $mailName $mailUser $mailSys \ - $mailTipNum] - } - /sendmail.html { - source $SRCDIR/mail.tcl - set cmd [list mail::mailformaccept] - } - default { - set cmd [list serveFile $what] - } - } - } error]} { - generr "Internal Error" "unexpected condition \"$error\" occurred" \ - $errorInfo 500 $errorCode - } - if {[catch $cmd error]} { - generr "Internal Error" "unexpected condition \"$error\" occurred" \ - $errorInfo 500 $errorCode - } -} -exit 0 DELETED tiparchive.tcl Index: tiparchive.tcl ================================================================== --- tiparchive.tcl +++ /dev/null @@ -1,34 +0,0 @@ -#! /usr/local/bin/tclsh8.0 - -set SRCDIR [file join [pwd] [file dirname [info script]]] -set convert {} -set pwd [pwd] -catch { - source $SRCDIR/config.tcl - source $SRCDIR/parse.tcl - source $SRCDIR/tiptex.tcl - - proc tiptex::puts {args} { - global convert - switch [llength $args] { - 2 {append convert [lindex $args 1]} - 1 {append convert [lindex $args 0] "\n"} - } - } - tiptex::generateWholeArchive - switch -- [lindex $argv 1] { - ps { - linkEPSImagesForDocument all $pwd - } - pdf { - makePDFImagesForDocument all $pwd - } - } - - set f [open [file join $pwd [lindex $argv 0]] w] - puts -nonewline $f $convert - close $f - exit -} -puts $errorInfo -exit 1 DELETED tiphtml.tcl Index: tiphtml.tcl ================================================================== --- tiphtml.tcl +++ /dev/null @@ -1,948 +0,0 @@ -namespace eval tiphtml { - variable curlev -1 - variable contexts {} - variable nextrefcounter 0 - - proc codechar {c} { - scan $c %c char - format %%%02x [expr {$char & 0xff}] - } - proc formcode {key args} { - regsub -all {[^a-zA-Z0-9]} [join $args] {[codechar \\&]} str - return $key=[subst $str] - } - proc nextrefnum {} { - variable nextrefcounter - incr nextrefcounter - } - proc xformdots {str} { - regsub -all {[.]} $str " dot " str - return $str - } - proc xformmailto {str {tip {}}} { - global BASEURL - set url ${BASEURL}mail.html? - regsub -all {[];${}\\[]} $str {\\&} str - # Make nameless subst - regsub -all "href=\"mailto:(\[^@]+)@(\[^\",]+)\"" $str \ - "href=\"$url\[formcode user \\1],\[formcode sys\ - \\2],tipnum=$tip\"" str - # Make named subst - regsub -all "href=\"mailto:(\[^@]+)@(\[^\",]+),(\[^\"]+)\"" $str \ - "href=\"$url\[formcode user \\1],\[\ - formcode sys \\2],\[formcode name \\3],tipnum=$tip\"" str - # Perform substitutions - subst $str - } - proc xformauthor {name email tip {longFmt 0}} { - set name [string trim $name] - foreach {user sys} [split $email @] {break} - set user [xformdots $user] - set sys [xformdots $sys] - if {$longFmt} { - if {[string length $name]} { - set link "$name <${user} at ${sys}>" - } else { - set link "${user} at ${sys}" - } - } elseif {[string length $name]} { - set link "$name" - } else { - set link "$user at $sys" - } - return [xformmailto $link $tip] - } - - proc enterlistcontext {level good bad1 bad2} { - variable curlev - variable contexts - if {$level > $curlev} { - incr curlev - lappend contexts "" - puts -nonewline "<$good compact>" - } - switch [lindex $contexts end] "" - "" { - puts -nonewline [lindex $contexts end] - puts -nonewline "<$good compact>" - set contexts [lreplace $contexts end end ""] - } - } - proc closecontext {{level -1}} { - variable curlev - variable contexts - while {$level < $curlev} { - incr curlev -1 - puts -nonewline [lindex $contexts end] - set contexts [lrange $contexts 0 [expr {[llength $contexts]-2}]] - } - } - proc quoteLiteral {string} { - # In 8.3 or later, we'd use [string map] for this. But this - # code has to work with 8.0 so we're stuck with [regsub -all] - regsub -all & $string {\&} string - regsub -all < $string {\<} string - regsub -all > $string {\>} string - regsub -all \" $string {\"} string - regsub -all \xa0 $string {\ } string - return $string - } - - proc section {title {level 1}} { - closecontext - incr level - puts "[quoteLiteral $title]" - } - proc ordinary {string} { - continuation -1 $string - } - proc bulleting {level body} { - closecontext $level - enterlistcontext $level ul ol dl - puts -nonewline "
  • " - continuation $level $body - } - proc description {tag level body} { - closecontext $level - enterlistcontext $level dl ol ul - puts -nonewline "
    $tag
    " - continuation $level $body - } - proc enumeration {tag level body} { - closecontext $level - enterlistcontext $level ol dl ul - if {$tag != 1} { - puts -nonewline "
  • " - } else { - puts -nonewline "
  • " - } - continuation $level $body - } - proc continuation {level body} { - global EmailRE URLRE TIPURLRE ShortTIPRE BASEURL ISSUEBASE ISSUEURLRE - variable thisTIPnumber - - closecontext $level - regsub -all $EmailRE $body "\x81mailto:\\1\x82" body - regsub -all $TIPURLRE $body "$BASEURL\\1.html" body - regsub -all $ISSUEURLRE $body "$ISSUEBASE\\1" body - set body [quoteLiteral $body] - - #regsub -all {[][\\ $;]} $body {\\&} body - #regsub -all $URLRE $body "\[addwbr &\]" body - #set body [subst -novar $body] - regsub -all {\[\[} $body \x83 body - regsub -all {\]\]} $body \x84 body - regsub -all \\\[($URLRE)\\\] $body "\x83\x85\x84" body - regsub -all $URLRE $body "&" body - - regsub -all {'''(('?[^'])+)'''} $body "\x87\\1" body - regsub -all {''(('?[^'\x87])+)''} $body "\\1" body - regsub -all $ShortTIPRE $body "TIP #\\1" body - regsub -all {\[} $body \x83 body - regsub -all {\]} $body \x84 body - #mail address monkeying... - if {[info exist thisTIPnumber]} { - set body [xformmailto $body $thisTIPnumber] - } else { - set body [xformmailto $body] - } - regsub -all {>mailto:([^][{};\\$<>@]+)@([^][{};\\$<>@]+)<} $body \ - ">\[xformdots \\1\] at \[xformdots \\2\]<" body - regsub -all \x85 $body {[nextrefnum]} body - regsub -all \x81 [subst -novar -noback $body] "\\<" body - regsub -all \x82 $body "\\>" body - regsub -all \x83 $body \[ body - regsub -all \x84 $body \] body - regsub -all \x86 $body : body - regsub -all \x87 $body {} body - variable curlev - if {$curlev==-1 && $level==1} { - puts "

    $body

    " - } else { - puts "

    $body

    " - } - } - proc separator {} { - closecontext - puts "
    " - } - proc verbatim {lines} { - puts "
    "
-	foreach line $lines {
-	    # HTML ignores formfeed chars, but we want to see them...
-	    regsub -all {} [quoteLiteral $line] "^L" line
-	    puts $line
-	}
-	puts -nonewline "
    " - } - - # Helpers to generate 'long' style indices - proc tr {c1 c2 {size 1}} { - puts -nonewline "$c1" - puts "$c2" - } - proc longidx {tpat {srch ""} {searchbody 0}} { - set matched 0 - if {[string match 8.0* [info tclversion]] && [string length $srch]} { - regsub -all {[^a-zA-Z0-9]} $srch {\\&} RE - } else { - set RE ***=$srch - } - foreachTIP d { - # must match type pattern and - if { - ![string match $tpat [string tolower $d(Type)]] || - ([string length $srch] && - ![regexp $RE "TIP #$d(TIP): $d(Title)"] && - (![info exist d(Keywords)] || - [lsearch -regexp $d(Keywords) $RE] < 0) && - ![regexp $RE $d(Abstract)] && - (!$searchbody || [lsearch -regexp $d(Body) $RE] < 0)) - } then { - continue - } - set matched 1 - puts "

    " - - puts -nonewline "" - puts "TIP #$d(TIP):\ - $d(Title)" - puts "
    $d(Version)
    " - ordinary $d(Abstract) - puts "
    " - - puts "
    " - set at "Author:" - global AuthorRE - foreach a $d(Author) { - regexp "^$AuthorRE" $a -> name mail - tr $at [xformauthor $name $mail $d(TIP)] - #tr $at "$name" - set at "" - } - tr Type: $d(Type) - if {[info exist d(Tcl-Version)]} { - tr "Tcl Version:" $d(Tcl-Version) - } - tr State: $d(State) - tr Vote: $d(Vote) - tr Created: [clock format $d(Created) -format "%d %b %Y" -gmt 1] - tr "Posting History:" [join [split $d(Post-History) ","] "
    "] - if {[info exist d(Discussions-To)]} { - set dtlink {} - foreach dt [split $d(Discussions-To) ,] { - regsub "^(mailto|news):" $dt "" dtnproto - lappend dtlink "$dtnproto" - } - tr "Discussions To:" [join $dtlink "
    "] - } - if {[info exist d(Obsoletes)]} { - tr Obsoletes: "TIP #$d(Obsoletes)" - } - if {[info exist d(Obsoleted-By)]} { - tr "Obsoleted By:" "TIP #$d(Obsoleted-By)" - } - if {[info exist d(Vote-By)]} { - if {$d(Vote-By) > [clock seconds]} { - tr Vote: [clock format $d(Vote-By) -gmt 1 \ - -format "%d %b %Y, %H:%M GMT"] - } else { - tr Vote-By: [clock format $d(Vote-By) -gmt 1 \ - -format "%d %b %Y, %H:%M GMT (closed)"] - } - } - if {[info exist d(Votes-For)]} { - tr Votes-For: $d(Votes-For) - } - if {[info exist d(Votes-Against)]} { - tr Votes-For: $d(Votes-For) - } - if {[info exist d(Votes-Abstained)]} { - tr Votes-For: $d(Votes-For) - } - if {[info exist d(Keywords)]} { - set kws {} - set kwl 0 - set comma "" - foreach k $d(Keywords) { - append kws $comma $k - incr kwl [string length $k] - if {$kwl > 12} { - set kwl 0 - set comma ",
    " - } else { - set comma ", " - } - } - tr Keywords: $kws - } - puts "
    " - } - if {!$matched} { - puts "

    No existing TIPs matched your\ - search criteria.

    " - } - } - proc stest {flagname state} { - upvar 1 flag flagAry d headers - expr {$flagAry($flagname) && ![string compare $headers(State) $state]} - } - proc longidx2 {locus pat1 pat2 dateLimit daterel order} { - array set flag { - titles 0 - keywords 0 - abstracts 0 - bodies 0 - authors 0 - created 0 - nofinal 0 - nodraft 0 - project 0 - noreject 0 - } - foreach feature $locus {set flag($feature) 1} - set matched {} - if {[string match 8.0* [info tclversion]]} { - regsub -all {[^a-zA-Z0-9]} $pat1 {\\&} RE1 - regsub -all {[^a-zA-Z0-9]} $pat2 {\\&} RE2 - } else { - set RE1 ***=$pat1 - set RE2 ***=$pat2 - } - if {$flag(created)} { - regsub -- (.+)-(.+)-(.+) $dateLimit {\2 \1, \3} dateLimit - set dateLimit [clock scan $dateLimit -gmt 1] - } - foreachTIP d { - # skip some TIPs if requested - if { - [stest nofinal Final] || [stest nodraft Draft] || - [stest noreject Rejected] || [stest noreject Withdrawn] || - ($flag(project) && [string compare $d(Type) Project]) - } then { - continue - } - # Perform main search - if { - [string length $pat1] && - (!$flag(titles) || ![regexp $RE1 "TIP #$d(TIP): $d(Title)"]) && - (!$flag(keywords) || [info exist d(Keywords)] && [lsearch -regexp $d(Keywords) $RE1]<0) && - (!$flag(abstracts) || ![regexp $RE1 $d(Abstract)]) && - (!$flag(bodies) || [lsearch -regexp $d(Body) $RE1]<0) - } then { - continue - } - # Perform author filtering - if {$flag(authors) && [lsearch -regexp $d(Author) $RE2]<0} { - continue - } - # Perform date filtering - if {$flag(created)} { - switch -- $daterel { - on { - if {$d(Created) != $dateLimit} {continue} - } - before { - if {$d(Created) >= $dateLimit} {continue} - } - after { - if {$d(Created) <= $dateLimit} {continue} - } - default { - continue - } - } - } - lappend matched [list $d($order) [array get d]] - } - if {[array exists d]} { - unset d - } - foreach match [lsort -dictionary -index 0 $matched] { - array set d [lindex $match 1] - puts "

    " - - puts -nonewline "" - puts "TIP #$d(TIP):\ - $d(Title)" - puts "
    $d(Version)
    " - ordinary $d(Abstract) - puts "
    " - - puts "
    " - set at "Author:" - global AuthorRE - foreach a $d(Author) { - regexp "^$AuthorRE" $a -> name mail - tr $at [xformauthor $name $mail $d(TIP)] - #tr $at "$name" - set at "" - } - tr Type: $d(Type) - if {[info exist d(Tcl-Version)]} { - tr "Tcl Version:" $d(Tcl-Version) - } - tr State: $d(State) - tr Vote: $d(Vote) - tr Created: [clock format $d(Created) -format "%d %b %Y" -gmt 1] - tr "Posting History:" [join [split $d(Post-History) ","] "
    "] - if {[info exist d(Discussions-To)]} { - set dtlink {} - foreach dt [split $d(Discussions-To) ,] { - regsub "^(mailto|news):" $dt "" dtnproto - lappend dtlink "$dtnproto" - } - tr "Discussions To:" [join $dtlink "
    "] - } - if {[info exist d(Obsoletes)]} { - tr Obsoletes: "TIP #$d(Obsoletes)" - } - if {[info exist d(Obsoleted-By)]} { - tr "Obsoleted By:" "TIP #$d(Obsoleted-By)" - } - if {[info exist d(Vote-By)]} { - if {$d(Vote-By) > [clock seconds]} { - tr Vote: [clock format $d(Vote-By) -gmt 1 \ - -format "%d %b %Y, %H:%M GMT"] - } else { - tr Vote-By: [clock format $d(Vote-By) -gmt 1 \ - -format "%d %b %Y, %H:%M GMT (closed)"] - } - } - if {[info exist d(Votes-For)]} { - tr Votes-For: $d(Votes-For) - } - if {[info exist d(Votes-Against)]} { - tr Votes-For: $d(Votes-For) - } - if {[info exist d(Votes-Abstained)]} { - tr Votes-For: $d(Votes-For) - } - if {[info exist d(Keywords)]} { - set kws {} - set kwl 0 - set comma "" - foreach k $d(Keywords) { - append kws $comma $k - incr kwl [string length $k] - if {$kwl > 12} { - set kwl 0 - set comma ",
    " - } else { - set comma ", " - } - } - tr Keywords: $kws - } - puts "
    " - unset d - } - if {![llength $matched]} { - puts "

    No existing TIPs matched your\ - search criteria.

    " - } - } - - # Helpers to generate 'medium' style indices - proc medcell {size colour style link content {hover ""}} { - set content [quoteLiteral $content] - if {[string length $style]} { - set content <$style>$content - } - set title "" - if {[string length $hover]} { - set title "title=\"$hover\"" - } - return "$content" - } - proc medhdr {link content} { - puts "$content" - } - proc getStyle {type vote state} { - upvar d d split split - switch -glob -- $type { - Info* {set ty i;set style i} - Project {set ty j;set style ""} - Process {set ty c;set style b} - } - set ty2 $ty - if {$split} {set style ""} - switch $vote { - "In progress" { - set bgcol yellow - append ty2 v - } - Pending { - set bgcol white - append ty2 p - } - Done - "No voting" { - set bgcol "" - append ty2 f - } - } - switch $state { - Draft { - if {[info exist d(Obsoleted-By)]} { - set col #606060 - } elseif {$bgcol != "yellow"} { - set col #006000 - } else { - set col black - } - append ty2 . - } - Withdrawn - Rejected { - set bgcol #c0c0c0 - if {[info exist d(Obsoleted-By)]} { - set col #606060 - } else { - set col #404040 - } - append ty2 x - } - Accepted { - set bgcol #CCCCFF - if {[info exist d(Obsoleted-By)]} { - set col #606060 - } else { - set col black - } - append ty2 ! - } - Deferred { - set bgcol #CCFFCC - set col black - append ty2 d - } - Final { - if {[info exist d(Obsoleted-By)]} { - set col #606060 - } else { - set col black - } - append ty2 F - } - default { - if {[info exist d(Obsoleted-By)]} { - set col #606060 - } else { - set col black - } - append ty2 - - } - } - if {[info exist d(Obsoleted-By)]} { - append ty2 o - } - list $ty $col $bgcol $style $ty2 - } - proc medidx {tpat order url} { - set split [expr \ - {![string compare $order none] && ![string compare $tpat *]}] - set HR "
    " - - set url [string trimleft $url /]?type=$tpat,sort - medhdr $url[expr {$order=="0"?"=-":"="}]0 "Series ID" - medhdr $url[expr {$order=="1"?"=-":"="}]1 "Type" - medhdr $url[expr {$order=="2"?"=-":"="}]2 "State" - medhdr $url[expr {$order=="3"?"=-":"="}]3 "Title" - puts -nonewline "$HR" - array set rows {} - if {[regexp {^-([0-3])} $order -> digit]} { - set rev -decreasing - set order $digit - } else { - set rev -increasing - } - foreachTIP d { - if {![string match $tpat [string tolower $d(Type)]]} { - continue - } - foreach {ty col bgcol style ty2} \ - [getStyle $d(Type) $d(Vote) $d(State)] {} - - set hover "" - switch -glob -- $ty2 { - *v* {set hover "A vote is in progress on this TIP"} - j*d* {set hover "This TIP has been deferred"} - j*!* {set hover "This TIP awaits implementation"} - j*.* {set hover "This TIP is still in discussion"} - j*F* {set hover "This TIP is in the core, version $d(Tcl-Version)"} - *x* {set hover "This TIP was not adopted by the TCT"} - *o {set hover "This TIP is obsolete"} - } - - set cols {} - lappend cols $d(TIP) \ - [medcell 2 $col $style $d(TIP).html TIP\ #$d(TIP) $hover] - if {![string compare $d(Type) Project]} { - lappend cols $d(Type) \ - [medcell 1 $col $style $d(TIP).html \ - $d(Type)\xa0($d(Tcl-Version)) $hover] - } else { - lappend cols $d(Type) \ - [medcell 1 $col $style $d(TIP).html $d(Type) $hover] - } - lappend cols $d(State) \ - [medcell 1 $col $style $d(TIP).html $d(State) $hover] - lappend cols $d(Title) \ - [medcell 2 $col $style $d(TIP).html $d(Title) $hover] - lappend cols $bgcol {} - lappend rows(all) $cols - lappend rows($ty) $cols - } - - if {!$split} { - set index 0 - catch { - if {$order>=0 && $order<4} { - set index [expr {int($order*2)}] - } - } - foreach row [lsort -dictionary $rev -index $index $rows(all)] { - set bgcol [lindex $row 8] - if {[string length $bgcol]} { - puts "" - } else { - puts "" - } - foreach {index col} $row { - if {[string length $col]} { - puts $col - } - } - puts -nonewline "" - } - puts -nonewline $HR - return - } - - set sep "" - foreach {ty Name} { - c "Process TIPs" - i "Informational TIPs" - j "Project TIPs" - } { - if {![info exist rows($ty)]} {continue} - puts "$Name" - foreach row $rows($ty) { - set bgcol [lindex $row 8] - if {[string length $bgcol]} { - puts "" - } else { - puts "" - } - foreach {index col} $row { - if {[string length $col]} { - puts $col - } - } - puts -nonewline "" - } - puts -nonewline $HR - } - puts "" - puts "

    Search archive\ - for TIPs containing:
    \ -  Advanced Search

    " - puts "
    " - } - variable shortIndexLastAnchor 0 - proc index {kind {errorKind soft} {tpat *}} { - global AuthorRE - closecontext - # Kinds of indices? short, medium, long, bibtex - switch -- $kind { - short { - variable shortIndexLastAnchor - foreachTIPreverse d { - if {![string match $tpat [string tolower $d(Type)]]} { - continue - } - puts -nonewline "

    name - puts "title=\"Author: $name" - puts "Type: $d(Type)" - puts "State: $d(State)" - puts -nonewline "Voting: $d(Vote)\"" - puts -nonewline ">TIP #$d(TIP):" - switch -glob -- $d(State),$d(Vote) { - "*,In progress" { - puts -nonewline " Voting" - } - "Draft,No voting" { - # No special tag - } - Accepted,* { - puts -nonewline " Accepted" - } - Draft,* { - puts -nonewline " Draft" - } - Rejected,* { - puts -nonewline " Rejected" - } - Withdrawn,* { - puts -nonewline " Withdrawn" - } - } - puts "
    $d(Title)

    " - } - } - medium { - global orderingColumn what - puts "
    " - medidx $tpat $orderingColumn $what - puts "
    " - } - long { - longidx $tpat - } - default { - if {[string compare $errorKind soft]} { - return -code error "Index style $kind not supported" - } - puts "

    Index\ - style \"$kind\" not yet supported!

    " - } - } - } - - if {![llength [info command ::imwidth::getImageWidth]]} { - source $SRCDIR/imwidth.tcl - } - proc image {bodytext} { - global ImageRE DOCDIR contenttypes - closecontext - set caption {} - set w 0 - regexp $ImageRE [string trim $bodytext] -> url caption - if {[regexp {^[-_a-zA-Z0-9]+$} $url]} { - foreach {ext type} [array get contenttypes] { - # Order is random, but shouldn't matter. - if { - [string match image/* $type] && - [file exists [set f [file join $DOCDIR $url$ext]]] - } then { - set w [::imwidth::getImageWidth $f] - set url $url$ext - break - } - } - } - set imgtag [format {img src="%s"} $url] - if {[string length $caption]} { - append imgtag " alt=\"[quoteLiteral $caption]\"" - } - if {$w > 450} { - set imgtag "a href=\"$url\"><$imgtag width=\"85%\"> 0} { - append imgtag " width=\"$w\"" - } - puts "

    <$imgtag>

    " - } - - proc fmtauthor {author tip} { - global AuthorRE - regexp "^$AuthorRE$" $author -> name email - return [xformauthor $name $email $tip 1] - } - - proc generateTIPHeader {head {revisioninfo {}}} { - # generate HTML header - array set h $head - global BASETARG BASEURL CSSURL ICONURL - puts "" - if {[string length $revisioninfo]} { - set title "TIP #$h(TIP) Version $revisioninfo: $h(Title)" - } else { - set title "TIP #$h(TIP): $h(Title)" - } - puts "$title" - puts "" - puts "" - puts "" - if {[info exist h(Keywords)]} { - set keywords [join $h(Keywords) ", "] - puts "" - } - puts "" - puts "" - puts "" - if {[string length $revisioninfo]} { - puts "

    $title

    This is not\ - necessarily the current version of this\ - TIP.

    " - } else { - puts "

    $title

    " - } - variable thisTIPnumber $h(TIP) - puts "" - puts "" - puts "" - switch [llength $h(Author)] { - 0 {} - 1 { - set a [fmtauthor [lindex $h(Author) 0] $h(TIP)] - puts "" - } - default { - puts "" - } - } - foreach tag {State Type Tcl-Version Vote Votes-For Votes-Against Votes-Abstained} { - if {[info exist h($tag)] && [string length $h($tag)]} { - puts "${tag}:" - } - } - set t [clock format $h(Created) -format {%A, %d %B %Y} -gmt 1] - puts "" - if {[info exist h(Vote-By)]} { - set t [clock format $h(Vote-By) -gmt 1 \ - -format {%A, %d %B %Y, %H:%M GMT}] - if {$h(Vote-By) > [clock seconds]} { - puts "" - } else { - puts "" - } - } - foreach tag {Post-History} { - if {[string length $h($tag)]} { - puts "${tag}:" - } - } - if { - [info exist h(Discussions-To)] && - [string length $h(Discussions-To)] - } { - foreach dt [split $h(Discussions-To) ,] { - set dt [string trim $dt] - puts -nonewline "Discussions To:" - } else { - puts "$dt" - } - } - } - foreach tag {Obsoletes Obsoleted-By} { - if {[info exist h($tag)] && [string length $h($tag)]} { - puts "" - } - } - if {[info exist h(Keywords)]} { - puts "" - } - puts "
    TIP:$h(TIP)
    Title:$h(Title)
    Version:$h(Version)
    Author:$a
    Authors:" - foreach a $h(Author) {puts "[fmtauthor $a $h(TIP)]
    "} - puts "
    $h($tag)
    Created:$t
    Vote-By:$t
    Vote-By:$t\ - (Vote Closed)
    $h($tag)
    " - global URLRE - if {[regexp ^$URLRE$ $dt]} { - puts "$dt
    ${tag}:TIP #$h($tag)
    Keywords:[join $h(Keywords) {, }]
    " - } - - proc clickelem {url mouseover text} { - upvar elems elems - regsub -all { } $text {\ } text - lappend elems [format "\[%s\]" $url $mouseover $mouseover $text] - } - proc generateDocument {head body {revision ""}} { - array set h $head - generateTIPHeader $head $revision - - # generate HTML body - foreach par $body { - eval [intuitParagraphKind $par] - } - - # generate HTML footer - separator - global FOOTERTEXT FEATURE CVSWEBURL EDITURLBASE - global TCLLOGOURL TCLLOGOX TCLLOGOY - if {[string length $revision]} { - puts "

    \"PoweredThis is not\ - necessarily the current version of this\ - TIP.

    $FOOTERTEXT
    " - return - } - set elems {} - clickelem 1.html "Go to the index page" Index - if {$FEATURE(CVSWEB)} { - clickelem [format $CVSWEBURL $h(TIP)] \ - "Go to document history" History - } - if {($FEATURE(EDIT) || $FEATURE(EDIT_URL_HTML))&& ![notEditable? h]} { - clickelem $EDITURLBASE/$h(TIP) "Edit this TIP" Edit - } - clickelem $h(TIP).html "Format as HTML" "HTML Format" - clickelem $h(TIP).tip "View source" "Source Format" - clickelem $h(TIP).tex "Format as LaTeX" "LaTeX Format" - clickelem $h(TIP).txt "Format as plain text" "Text Format" - clickelem $h(TIP).xml "Format as XML" "XML Format" - clickelem $h(TIP).ms "Format as *roff with -ms macro package" \ - "*roff Format (experimental)" - clickelem $h(TIP).rtf "Format as rich text" \ - "RTF Format (experimental)" - puts "

    \"Powered[join $elems]

    " - puts "
    $FOOTERTEXT
    " - } -} DELETED tipmode.el Index: tipmode.el ================================================================== --- tipmode.el +++ /dev/null @@ -1,454 +0,0 @@ -;;; tipmode.el --- A mode for editing Tcl Improvement Proposals. - -;; Copyright (C) 2000 Donal K. Fellows - -(defconst tip-mode-revision-string "$Id: tipmode.el,v 1.13 2004/08/09 22:15:14 dkf Exp $" - "Some CVS/RCS info relating to tipmode.el...") - -;(require 'text) ; text-mode always available? - -(defgroup tip nil "Major mode for editing Tcl Improvement Proposals." - :group 'tcl - :group 'text - :prefix "tip-") - -(defgroup tipface nil "Faces used when highlighting TIPs." - :group 'tip - :group 'faces) - -(defcustom tip-mode-hook nil - "Normal hook run when entering TIP mode." - :type 'hook - :group 'tip) - -(defcustom tip-skeleton-head - "TIP: ??? -Title: Title for Skeleton TIP -State: Draft -Type: Project -Tcl-Version: 9.0 -Vote: Pending -Post-History: " - "*A skeleton of a TIP header, minus certain derivable/computed fields." - :type 'string - :group 'tip) - -(defcustom tip-skeleton-body "~ Abstract - -A ''single'' paragraph, in third person voice, outlining what your TIP -is all about. - -~ Rationale - -Why is this TIP needed? - -~ Proposed Change - -What are you going to do? ''This need not include a patch during -initial discussion, and should not include a verbatim patch at all -(due to publishing restrictions.)'' - -~ Copyright - -This document has been placed in the public domain. -" "*A skeleton of a TIP body, a suitable place to start writing your own." - :type 'string - :group 'tip) - - - -(defvar tip-header-key-face 'tip-header-key-face - "Face name to use for keys in TIP headers.") -(defvar tip-header-value-face 'tip-header-value-face - "Face name to use for values in TIP headers.") -(defvar tip-verbatim-face 'tip-verbatim-face - "Face name to use for verbatim text in TIPs.") -(defvar tip-magic-paragraph-start-face 'tip-magic-paragraph-start-face - "Face name to use for symbol sequences that start specially -meaningful paragraphs in TIPs.") -(defvar tip-section-title-face 'tip-section-title-face - "Face name to use for section titles in TIPs.") -(defvar tip-magic-paragraph-info-face 'tip-magic-paragraph-info-face - "Face name to use for extra info that follow paragraph starts with -special meaning in TIPs.") -(defvar tip-list-start-face 'tip-list-start-face - "Face name to use for list item start sequences in TIPs.") -(defvar tip-uri-face 'tip-uri-face - "Face name to use for URIs in TIPs.") - -(defface tip-header-key-face ;copy of font-lock-builtin-face - '((((class grayscale) (background light)) (:foreground "LightGray" :bold t)) - (((class grayscale) (background dark)) (:foreground "DimGray" :bold t)) - (((class color) (background light)) (:foreground "Purple")) - (((class color) (background dark)) (:foreground "Cyan")) - (t (:bold t))) - "Face for highlighting keys in TIP headers." - :group 'tipface) -(defface tip-header-value-face ;copy of font-lock-function-name-face - '((((class color) (background light)) (:foreground "Blue")) - (((class color) (background dark)) (:foreground "LightSkyBlue")) - (t (:inverse-video t :bold t))) - "Face for highlighting values in TIP headers." - :group 'tipface) -(defface tip-verbatim-face ;copy of font-lock-string-face - '((((class grayscale) (background light)) (:foreground "DimGray" :italic t)) - (((class grayscale) (background dark)) (:foreground "LightGray" :italic t)) - (((class color) (background light)) (:foreground "RosyBrown")) - (((class color) (background dark)) (:foreground "LightSalmon")) - (t (:italic t))) - "Face for highlighting verbatim paragraphs in TIPs." - :group 'tipface) -(defface tip-magic-paragraph-start-face ;copy of font-lock-function-name-face - '((((class color) (background light)) (:foreground "Blue")) - (((class color) (background dark)) (:foreground "LightSkyBlue")) - (t (:inverse-video t :bold t))) - "Face for highlighting symbol sequences that start specially -meaningful paragraphs in TIPs." - :group 'tipface) -(defface tip-magic-paragraph-info-face ;copy of font-lock-variable-name-face - '((((class grayscale) (background light)) - (:foreground "Gray90" :bold t :italic t)) - (((class grayscale) (background dark)) - (:foreground "DimGray" :bold t :italic t)) - (((class color) (background light)) (:foreground "DarkGoldenrod")) - (((class color) (background dark)) (:foreground "LightGoldenrod")) - (t (:bold t :italic t))) - "Face for highlighting extra info that follow paragraph starts with -special meaning in TIPs." - :group 'tipface) -(defface tip-section-title-face ;copy of font-lock-constant-face - '((((class grayscale) (background light)) - (:foreground "LightGray" :bold t :underline t)) - (((class grayscale) (background dark)) - (:foreground "Gray50" :bold t :underline t)) - (((class color) (background light)) (:foreground "CadetBlue")) - (((class color) (background dark)) (:foreground "Aquamarine")) - (t (:bold t :underline t))) - "Face for highlighting section titles in TIPs." - :group 'tipface) -(defface tip-list-start-face ;copy of font-lock-function-name-face - '((((class color) (background light)) (:foreground "Blue")) - (((class color) (background dark)) (:foreground "LightSkyBlue")) - (t (:inverse-video t :bold t))) - "Face for highlighting list item start sequences in TIPs." - :group 'tipface) -(defface tip-uri-face - '((t (:underline t))) - "Face for highlighting URIs in TIPs." - :group 'tipface) - -(defvar tip-mode-syntax-table (make-syntax-table text-mode-syntax-table) - "Syntax table used while in TIP mode.") - -(defvar tip-mode-abbrev-table nil - "Abbrev table used while in TIP mode.") -(define-abbrev-table 'tip-mode-abbrev-table ()) - -(defvar tip-mode-map () "Keymap for TIP mode.") -(if tip-mode-map - () - (setq tip-mode-map (copy-keymap text-mode-map)) - (let ((map (make-sparse-keymap))) - (define-key map "s" 'tip-insert-section-header) - (define-key map "i" 'tip-insert-image) - (define-key map "x" 'tip-insert-index) - (define-key map "v" 'tip-verbatim-region) - (define-key map "\C-c" 'tip-insert-skeleton) - (define-key map "p" 'tip-check-spelling) - (define-key map "h" 'tip-verify-headers) - (define-key tip-mode-map "\C-c" map) - (define-key tip-mode-map [menu-bar] (make-sparse-keymap)) - (define-key tip-mode-map [menu-bar tip] - (cons "TIP" (make-sparse-keymap "TIP"))) - (define-key tip-mode-map [menu-bar tip verbatim-region] - '("Verbatim Region" . tip-verbatim-region)) - (define-key tip-mode-map [menu-bar tip insert-image] - '("Insert Image" . tip-insert-image)) - (define-key tip-mode-map [menu-bar tip insert-index] - '("Insert Index" . tip-insert-index)) - (define-key tip-mode-map [menu-bar tip insert-section-header] - '("Insert Section" . tip-insert-section-header)) - (define-key tip-mode-map [menu-bar tip check-spelling] - '("Check Spelling" . tip-check-spelling)) - (define-key tip-mode-map [menu-bar tip verify-headers] - '("Verify Headers" . tip-verify-headers)) - (define-key tip-mode-map [menu-bar tip insert-skeleton] - '("Insert Skeleton" . tip-insert-skeleton)) - (put 'tip-verbatim-region 'menu-enable 'mark-active) - )) - -(defvar tip-font-lock-keywords - '(("^\\(#i\\(ndex\\|mage\\):\\)\\(\\S-*\\)" - (1 tip-magic-paragraph-start-face) (3 tip-magic-paragraph-info-face)) - ("^\\(~\\)\\s-*\\(\\S-.*\\)" - (1 tip-magic-paragraph-start-face) (2 tip-section-title-face)) - ("^\\(\\(T\\(IP\\|itle\\|ype\\)\\|\\(Tcl-\\)?Version\\|Author\\|State\\|Vote\\(-By\\|s-\\(For\\|A\\(gainst\\|bstained\\)\\)\\)?\\|Created\\|Post-History\\|Obsolete\\(s\\|d-By\\)\\|Keywords\\|Discussions-To\\):\\)[ \t]*\\(\\(\\S-.*\\)?\\)" - (1 tip-header-key-face) (6 tip-header-value-face)) - ("^|.*" (0 tip-verbatim-face)) - ("^[ \t]+\\(\\(>\\s-+\\)*\\([*>]\\|[0-9]+.\\|.*:\\)\\)" - (1 tip-list-start-face)) - ("\\(https?\\|ftp\\|news\\|newsrc\\|mailto\\|gopher\\):\\([-a-zA-Z0-9.]+:[0-9]+/\\)?[-A-Za-z0-9/_.%#+@?=&;~]+" - (0 tip-uri-face)) - ("tip:[0-9]+" (0 tip-uri-face)) - ("<\\(\\S-+@\\S-+\\)>" (1 tip-uri-face))) - "Default expressions to highlight in TIP mode.") -(defvar tip-font-lock-defaults - '(tip-font-lock-keywords t nil nil mark-paragraph)) -(defvar tip-imenu-generic-expression - '((nil "^~\\s-*\\(.*\\)" 1))) - -;;;###autoload -(defun tip-mode () - "Major mode for editing TIP documents. -The following keys are bound: -\\{tip-mode-map} -" - (interactive) - (text-mode) - (set-syntax-table tip-mode-syntax-table) - (use-local-map tip-mode-map) - (make-local-variable 'imenu-generic-expression) - (make-local-variable 'font-lock-defaults) - (setq major-mode 'tip-mode - mode-name "TIP" - local-abbrev-table tip-mode-abbrev-table - imenu-generic-expression tip-imenu-generic-expression - font-lock-defaults tip-font-lock-defaults - ) - (imenu-add-to-menubar "Sections") - (run-hooks 'tip-mode-hook) - ) - -(defun tip-insert-paragraph (string) - (or (bolp) (insert "\n")) - (insert "\n" string "\n") - (or (eolp) (insert "\n"))) -(defun tip-insert-section-header (title) - "Insert a section header paragraph." - (interactive "*MSection title:") - (tip-insert-paragraph (format "~ %s" title))) -(defun tip-insert-index (kind) - "Insert an index paragraph." - (interactive (list (completing-read "Index kind: " - [short medium long] nil t nil - nil "medium"))) - (tip-insert-paragraph (format "#index:%s" kind))) -(defun tip-insert-image (url caption) - "Insert an image paragraph." - (interactive "*sURL to reference: \nMCaption for image: ") - (tip-insert-paragraph (format "#image:%s %s" url caption))) -(defun tip-verbatim-region (from to) - "Makes the lines including the region into verbatim text." - (interactive "*r") - (let (fm tm) - (goto-char from) - (beginning-of-line) - (setq fm (point-marker)) - (goto-char to) - (or (bolp) (end-of-line)) - (setq tm (point-marker)) - (untabify fm tm) - (goto-char fm) - (while (< (point) tm) - (beginning-of-line) - (insert "|") - (forward-line)) - (set-marker fm nil) - (set-marker tm nil))) - -(defun tip-insert-skeleton () - "Insert a skeleton TIP into the current buffer. -This allows people to get started writing a TIP much more rapidly." - (interactive) - (insert tip-skeleton-head) - (insert (format "%cVersion:%c%cRevision%c" 10 9 36 36)) - (insert (format "%cAuthor:%c%c%s <%s>" - 10 9 9 (user-full-name) user-mail-address)) - (insert (format-time-string "%nCreated:%t%d-%b-%Y")) - (insert (format "%c%c" 10 10)) - (insert tip-skeleton-body)) - -;; Copied and adapted shamelessly from ispell.el! -(defun tip-check-spelling () - (interactive) - (save-excursion - (goto-char (point-min)) - (let* ((end-of-headers ; Start of body. - (copy-marker - (or (re-search-forward "^$" nil t) - (point-min)))) - (limit (copy-marker ; End of region we will spell check. - (cond - ((not ispell-message-text-end) (point-max)) - ((char-or-string-p ispell-message-text-end) - (if (re-search-forward ispell-message-text-end nil t) - (match-beginning 0) - (point-max))) - (t (min (point-max) (funcall - ispell-message-text-end)))))) - (ispell-skip-region-alist - (cons (list "^|" (function forward-line)) - ispell-skip-region-alist)) - (old-case-fold-search case-fold-search) - (case-fold-search t) - (dictionary-alist ispell-message-dictionary-alist) - (ispell-checking-message t)) - (or (local-variable-p 'ispell-local-dictionary (current-buffer)) - (while dictionary-alist - (goto-char (point-min)) - (if (re-search-forward (car (car dictionary-alist)) - end-of-headers t) - (setq ispell-local-dictionary (cdr (car dictionary-alist)) - dictionary-alist nil) - (setq dictionary-alist (cdr dictionary-alist))))) - (unwind-protect - (progn - ;; Spell check any Title: or Keywords: - (goto-char (point-min)) - (while (re-search-forward "^\\(Title\\|Keywords\\): *" end-of-headers t) - (progn - (goto-char (match-end 0)) - (let ((case-fold-search old-case-fold-search)) - (ispell-region (point) - (progn ;Tab-initiated continuation lns. - (end-of-line) - (while (looking-at "\n[ \t]") - (end-of-line 2)) - (point)))))) - (goto-char end-of-headers) - (forward-line 1) - (ispell-region (point) limit)) - (set-marker end-of-headers nil) - (set-marker limit nil))))) - -(defconst tip-verify-states-re - "^\\(Draft\\|Accepted\\|Deferred\\|Final\\|Active\\|Rejected\\|Withdrawn\\)$" - "Regexp matching the acceptable values for the State: header field.") -(defconst tip-verify-types-re - "^\\(Project\\|Process\\|Inform.*\\)$" - "Regexp matching the acceptable values for the Type: header field.") -(defconst tip-verify-tclver-re - "^[0-9]+\\.[0-9]+\\([.ab][0-9]+\\)?$" - "Regexp matching the acceptable values for the Tcl-Version: header field.") -(defconst tip-verify-vote-re - "^\\(Pending\\|In progress\\|Done\\|No voting\\)$" - "Regexp matching the acceptable values for the Vote: header field.") -(defconst tip-verify-created-re - "^[0-9][0-9]-\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct\\|Nov\\|Dec\\)-20[0-9][0-9]$" - "Regexp matching the acceptable values for the Created: header field.") -(defconst tip-verify-author-re - "^.+ <.+@.+>$" - "Regexp matching the acceptable values for the Author: header field.") - -(defconst tip-header-matcher-alist - (list '("TIP" . "^[0-9]+$") - '("Title" . ".") - '("Version" . "^\$.+\$$") - (cons "State" tip-verify-states-re) - (cons "Type" tip-verify-types-re) - (cons "Tcl-Version" tip-verify-tclver-re) - (cons "Vote" tip-verify-vote-re) - (cons "Created" tip-verify-created-re) - (cons "Author" tip-verify-author-re) - '("Obsoletes" . "^[0-9]_$") - '("Obsoleted-By" . "^[0-9]_$") - '("Post-History" . ".*") - '("Discussions-To" . ".+") - '("Keywords" . ".+") - '("Vote-By" . ".+") - '("Votes-For" . ".+") - '("Votes-Against" . ".+") - '("Votes-Abstained" . ".+")) - "Alist of matchers for each of the legal TIP headers.") - -(defun tip-verify-headers () - "Perform a basic verification check on the TIP headers." - (interactive) - (save-excursion - (goto-char (point-min)) - (let ((headers) - (end-of-headers ; Start of body. - (copy-marker - (or (re-search-forward "^$" nil t) - (point-min))))) - (goto-char (point-min)) - (while (re-search-forward "^\\([-a-zA-Z]+\\):[ \t]*\\(.*\\)" - end-of-headers t) - (let* ((key (match-string 1)) - (body (match-string 2)) - (next (match-end 0)) - (re (assoc key tip-header-matcher-alist))) - (cond - ((not re) (error "Unknown header '%s:'" key)) - ((string-match (cdr re) body) - (setq headers (cons (cons key body) headers))) - (t (error "Illegal header '%s: %s'" key body))) - (goto-char next))) - (or (assoc "TIP" headers) (error "Missing header 'TIP:'")) - (or (assoc "Title" headers) (error "Missing header 'Title:'")) - (or (assoc "Version" headers) (error "Missing header 'Version:'")) - (or (assoc "State" headers) (error "Missing header 'State:'")) - (or (assoc "Type" headers) (error "Missing header 'Type:'")) - (or (assoc "Vote" headers) (error "Missing header 'Vote:'")) - (or (assoc "Created" headers) (error "Missing header 'Created:'")) - (or (assoc "Author" headers) (error "Missing header 'Author:'")) - (or (assoc "Post-History" headers) (error "Missing header 'Post-History:'")) - (let ((project (equal "Project" (cdr (assoc "Type" headers)))) - (tcl-version (assoc "Tcl-Version" headers))) - (if (and (not project) tcl-version) - (error "Can only have 'Tcl-Version:' header in Project TIPs")) - (if (and project (not tcl-version)) - (error "Must have 'Tcl-Version:' header in Project TIPs"))) - (message "TIP headers seem OK")))) - -;; Arrange for the mode to become associated with all buffers whose -;; filenames end in .tip, unless this has been done already... - -(if (assoc "\\.tip\\'" auto-mode-alist) () - (setq auto-mode-alist (cons '("\\.tip\\'" . tip-mode) auto-mode-alist))) -(message "%s" tip-mode-revision-string) - -(provide 'tipmode) - -;; $Log: tipmode.el,v $ -;; Revision 1.13 2004/08/09 22:15:14 dkf -;; Extend support for the new headers to the Emacs support -;; -;; Revision 1.12 2003/08/15 08:11:46 dkf -;; Omitted the Deferred state from the State: header checking RE. D'oh! -;; -;; Revision 1.11 2002/02/20 09:21:06 dkf -;; URLs can contain '%' so add it to match set. -;; -;; Revision 1.10 2002/01/10 11:57:11 dkf -;; Now have correctly functioning TIP header verifier. -;; -;; Revision 1.9 2001/12/18 14:12:14 dkf -;; More advanced online searching and some verification ability in the emacs mode -;; -;; Revision 1.8 2001/09/04 09:34:03 dkf -;; Substantive enhancement to tipmode.el (spelling+menu) -;; -;; Revision 1.7 2001/03/09 14:26:51 dkf -;; Supported https URLs and added a skeleton TIP generation function. -;; -;; Revision 1.6 2000/12/01 10:56:50 dkf -;; Improved autoloading. -;; -;; Revision 1.5 2000/11/21 15:25:29 dkf -;; Added a batch of "useful" editing commands. -;; -;; Revision 1.4 2000/11/21 10:25:54 dkf -;; Improved highlight regexps. -;; -;; Revision 1.3 2000/11/17 15:11:16 dkf -;; Improved support for other people's use and removed a stupid -;; font-definition bug. -;; -;; Revision 1.2 2000/11/15 14:17:07 dkf -;; Bugfixes... -;; -;; Revision 1.1 2000/11/15 11:49:51 dkf -;; Tweaked the LaTeX generator to remind people to get the accompanying -;; images, and added an emacs mode for editing TIPs. -;; DELETED tipms.tcl Index: tipms.tcl ================================================================== --- tipms.tcl +++ /dev/null @@ -1,218 +0,0 @@ -namespace eval tipms { - proc putspar {string} { - global TIPURLRE BASEURL ShortTIPRE ISSUEBASE ISSUEURLRE - regsub -all {'''(('?[^'])+)'''} $string "\x82\\fB\\1\\fR" string - regsub -all {''(('?[^'\x82])+)''} $string "\\fI\\1\\fR" string - regsub -all $TIPURLRE $string "$BASEURL\\1.html" string - regsub -all $ISSUEURLRE $string "$ISSUEBASE\\1" string - regsub -all {\[\[} $string \x80 string - regsub -all {\]\]} $string \x81 string - regsub -all $ShortTIPRE $string "\[TIP #\\1\]" string - regsub -all \x80 $string \[ string - regsub -all \x81 $string \] string - regsub -all \x82 $string {} string - if {[string match .* $string]} { - puts "\\$string" - } else { - puts $string - } - } - - variable counters {} - proc manageListCounters {level num} { - variable counters - if { - [regexp {^1$} $num] && - $level < [llength $counters] && - [lindex $counters $level] != "*" - } then { - set num [lindex $counters $level] - incr num - } - set counters [lrange [linsert $counters $level $num] 0 $level] - return [lindex $counters end] - } - variable incontext -1 - - proc setcontext {{level -1}} { - variable incontext - for {} {$incontext > $level} {incr incontext -1} {puts .RE} - for {} {$incontext < $level} {incr incontext} {puts .RS} - } - proc endcount {} { - variable counters {} - } - - proc section {title {level 1}} { - setcontext - endcount - puts ".NH $level\n\\fB$title\\fR" - } - proc ordinary {string} { - endcount - continuation -1 $string - } - proc item {tag level body} { - incr level -1 - setcontext $level - puts ".IP $tag" - putspar $body - } - proc bulleting {level body} { - manageListCounters $level * - set s [lindex {bu sq hy} [expr {$level % 3}]] - item "\\ \\($s" $level $body - } - proc enumeration {tag level body} { - set tag [manageListCounters $level $tag] - item "\" ${tag}: \"" $level $body - } - proc description {tag level body} { - manageListCounters $level * - item "\"$tag \"" $level $body - } - proc continuation {level body} { - variable incontext - if {$level != -1 && $incontext<0} { - puts .QP - } else { - if {$level > 0} { - setcontext [expr {$level-1}] - } else { - setcontext $level - } - puts .LP - } - putspar $body - } - proc separator {} { - endcount - setcontext - puts .Hl - } - proc verbatim {lines} { - puts .LD - foreach string $lines { - regsub -all "\[ \t\]" $string {\\&} string - if {[string match .* $string]} { - puts "\\$string" - } else { - puts $string - } - } - puts .DE - } - proc index {kind {errorKind soft} {tpat *}} { - endcount - setcontext - switch -- $kind { - medium { - puts ".TS H\ncenter;\nlb|lb|lb|lb." - puts "Series ID\tType\tState\tTitle\n_\n.TH" - puts ".T&\nl|l|l|lw(3.5i)." - foreachTIP d { - if {[string compare $d(Vote) "In progress"]} { - set v $d(State) - } else { - set v Voting - } - set t $d(Type) - if {[string match Info* $t]} {set t Info.} - puts "TIP #$d(TIP)\t$t\t$v\t\\fI$d(Title)\\fR" - } - puts ".TE" - } - short { - puts ".CD\n.TS\nc l.\n\\fBSeries ID\\fR\t\\fBTitle\\fR" - foreachTIP d { - puts "TIP #$d(TIP)\t$d(Title)" - } - puts ".TE\n.DE" - } - default { - if {[string compare $errorKind soft]} { - return -code error "Index style $kind not supported" - } - set msg "*Index style \"$kind\" not yet supported*" - regsub -all . $msg * stars - puts ".CD\n$stars\n$msg\n$stars\n.DE" - } - } - } - proc image {bodytext} { - endcount - setcontext - global ImageRE - puts .CD - if { - [regexp $ImageRE $bodytext -> url caption] && - [regexp {^[-_a-zA-Z0-9]+$} $url] - } then { - global DOCDIR - set fn [file join $DOCDIR $url.txt] - if {[file isfile $fn] && [file readable $fn]} { - set f [open $fn r] - set lines [split [read -nonewline $f] "\n"] - close $f - foreach line $lines { - puts " $line" - } - puts "" - putspar $caption - } - } elseif {[info exist url] && [info exist caption]} { - puts "" - putspar $caption - } else { - puts "<<$bodytext>>" - } - puts .DE - } - proc generateDocument {head body} { - array set h $head - puts {.\" t -.\" Note that this file *must* be preprocessed with tbl before being -.\" passed to *roff. Fail to do this and things will break... -.de Hl -.br -\l'\\n(.lu-\\n(.iu' -.sp -..} - puts ".TL\nTIP #$h(TIP): $h(Title)\n" - puts ".AU\n[join $h(Author) ,\n]" - puts [clock format $h(Created) -format ".DA \"%d %b %Y\"" -gmt 1] - switch $h(State) { - Accepted - Final - Active { - puts ".AI\nTcl Core Team" - } - Draft { - puts ".AI\n.BX DRAFT" - } - } - puts .AB - putspar [lindex [intuitParagraphKind [lindex $body 1]] 1] - puts .AE - puts ".TS\nbox;\nlb | lb.\nTIP #$h(TIP):\t$h(Title)" - puts "_\n.T&\nl | l." - foreach hdr { - Type State Vote Version Tcl-Version Post-History Discussions-To - Obsoletes Obsoleted-By Keywords Votes-For Votes-Against - Votes-Abstained - } { - if {![info exist h($hdr)]} {continue} - puts "${hdr}:\t$h($hdr)" - } - if {[info exist h(Vote-By)]} { - puts [clock format $h(Vote-By) -gmt 1 \ - -format "Vote-By:\t%d %b %Y, %H:%M GMT"] - } - puts .TE - puts .1C - foreach par [lrange $body 2 end] { - eval [intuitParagraphKind $par] - } - puts ".SH\nColophon\n.LP" - global FOOTERTEXT - puts $FOOTERTEXT - } -} DELETED tiprtf.tcl Index: tiprtf.tcl ================================================================== --- tiprtf.tcl +++ /dev/null @@ -1,210 +0,0 @@ -# TIP to RTF generator v0.1 -# No indices nor images supported -# No TIP headers generation -# Juan C. Gil -namespace eval tiprtf { - variable FONT - array set FONT {SANS 0 SERIF 1 TYPE 2 SYMB 3} - - # The indent amount - variable indent 426 - - # Enumeration counters - variable counters [list] - - # Generates the RTF header - proc RTF-documentHeader {tipnum title} { - puts "\{\\rtf1\\ansi\\ansicpg1252\\deff0\\deflang3082\ - \n{\\fonttbl\n{\\f0\\fswiss\\fcharset0\ - Arial;}\n{\\f1\\froman\\fprq2\\fcharset0 Times New\ - Roman;}\n{\\f2\\fmodern\\fprq1\\fcharset0 Courier\ - New;}\n{\\f3\\fnil\\fcharset2 Symbol;}\n}\ - \n\\viewkind4\\uc1\ - \n\\paperw11907\\paperh16840\\margl1797\\margr1797\n" - RTF-paragraph SANS 32 200 0 0 "\\b TIP #${tipnum}: $title\\b0" - separator - } - - # Generates the RTF header - proc RTF-documentTrailer {} { - puts \} - } - - # Generates a section heading - proc section {title {level 1}} { - variable counters [list] - if {$level > 4} {set level 4} - set size [lindex {32 24 20 16 14} $level] - RTF-paragraph SANS $size [expr {int($size*12)}] 0 0 $title - } - - # Generates an RTF paragraph heading - # f = font - # fs = font size - # sb = space between paragraphs - # li = left indent - # fi = first line indent - proc RTF-paragraph-heading {f fs sb li fi} { - variable FONT - puts [format {\pard\f%s\fs%s\sb%s\li%s\fi%s} \ - $FONT($f) $fs $sb $li $fi] - } - # Generates an RTF paragraph with leading and trailing matter - # All args as above, plus: - # str = body of the paragraph - proc RTF-paragraph {f fs sb li fi str} { - RTF-paragraph-heading $f $fs $sb $li $fi - puts "$str\\par\n" - } - - if {[catch {string repeat _ 77}]} { - proc strrep {str count} { - regsub -all " " [format %*s $count ""] $str var - set var - } - } else { - interp alias {} [namespace current]::strrep {} string repeat - } - # Generates a separator - proc separator {} { - variable counters [list] - RTF-paragraph SERIF 20 0 0 0 [strrep _ 77] - } - - # Generates a verbatim paragraph - proc verbatim {lines} { - variable indent - set sb 120 - foreach line $lines { - RTF-paragraph TYPE 20 $sb $indent 0 $line - set sb 0 - } - } - - # Generates a paragraph - proc paragraph {body {level 0} {bullet 0} {outdent 0} {usesTabs 0}} { - variable indent - - # NEED PROCESSING FOR BACKSLASH CHARACTERS AND OTHER ESCAPES! - - # Bold and emphasis - regsub -all {'''(('?[^'])+)'''} $body "\x81\\b \\1\\b0 " body - regsub -all {''(('?[^'\x81])+)''} $body "\\i \\1\\i0 " body - regsub -all \x81 $body "" body - - set li [expr {$level * $indent}] - if {$outdent} { - incr li $indent - RTF-paragraph-heading SERIF 20 120 $li -$indent - } else { - RTF-paragraph-heading SERIF 20 120 $li 0 - } - if {$usesTabs} { - set tab $indent - foreach i {1 2 3 4 5} { - puts -nonewline [format {\tx%s} $tab] - incr tab $indent - } - puts {} - } - if {$bullet} { - puts {{\*\pn\pnlvlblt\pnf3\pnindent0{\pntxtb\'B7}}} - } - puts "$body\\par\n" - } - - # Manages the enumeration counters - proc manage-counters {level number} { - variable counters - if { - ![string compare $number 1] && - $level < [llength $counters] && - [string compare [lindex $counters $level] *] - } then { - set number [lindex $counters $level] - incr number - } - set counters [lrange [linsert $counters $level $number] 0 $level] - return [lindex $counters end] - } - - # Generates an enumerated item - proc enumeration {tag level body} { - paragraph "[manage-counters $level $tag].\\tab $body" $level 0 1 1 - } - - # Generates a description item - proc description {tag level body} { - manage-counters $level * - paragraph "\\b $tag\\b0\\tab $body" $level 0 1 1 - } - - # Generates a bulleted item - proc bulleting {level body} { - manage-counters $level * - paragraph $body $level 1 1 - } - - # Generates a continuation paragraph - proc continuation {level body} { - paragraph $body $level - } - - # Generates an ordinary paragraph - proc ordinary {body} { - variable counters [list] - paragraph $body - } - - proc index {args} { - RTF-paragraph SANS 10 120 0 0 "indexes not implemented" - } - proc image {args} { - RTF-paragraph SANS 10 120 0 0 "images not implemented" - } - - proc RTF-tablerow {part1 part2 {font SERIF}} { - variable FONT - RTF-paragraph SERIF 11 0 0 0 "${part1}:\\tab{\\f$FONT($font) $part2}" - } - - # Generates the RTF document - proc generateDocument {head body} { - array set header $head - - # Generate the RTF header - RTF-documentHeader $header(TIP) $header(Title) - - # Generate the content header table - puts "\{\\tx1440" - RTF-tablerow TIP $header(TIP) - RTF-tablerow Title $header(Title) - RTF-tablerow Version $header(Version) TYPE - RTF-tablerow Authors [join $header(Author) "\\line\\tab "] - RTF-tablerow State $header(State) - RTF-tablerow Type $header(Type) - if {[info exist header(Tcl-Version)]} { - RTF-tablerow Tcl-Version $header(Tcl-Version) - } - RTF-tablerow Vote $header(Vote) - RTF-tablerow Created [clock format $header(Created)] - if {[info exist header(Keywords)]} { - RTF-tablerow Keywords [join $header(Keywords) ", "] - } - puts "\}" - - # Loop over paragraphs - foreach par $body { - eval [intuitParagraphKind $par] - } - - # Generate the content trailer - global FOOTERTEXT - separator - section Colophon - ordinary $FOOTERTEXT - - # Generate the RTF trailer - RTF-documentTrailer - } -} DELETED tiptex.tcl Index: tiptex.tcl ================================================================== --- tiptex.tcl +++ /dev/null @@ -1,623 +0,0 @@ -source $SRCDIR/imwidth.tcl -source $SRCDIR/epstopdf.tcl -namespace eval tiptex { - variable idxnum 0 - variable citations - array set citations {} - proc quote {body {dbs 0}} { - if {$dbs} { - regsub -all {\\} $body {\(\backslash\)} body - regsub -all {([{}])} $body {\\\1} body - } - regsub -all {LaTeX } $body {LaTeX\\ } body - regsub -all {LaTeX[^a-zA-Z]} $body {\\&} body - regsub -all < $body {\tiplangle{}} body - regsub -all > $body {\tiprangle{}} body - regsub -all {\|} $body {\tipbar{}} body - #regsub -all {[<>|]} $body {\(&\)} body - regsub -all {\^} $body {\textasciicircum{}} body - regsub -all {([%&_$#])} $body {\\\1} body - regsub -all ~ $body {\~{}} body - regsub -all { - } $body " \x80 " body - regsub -all {([0-9])--([0-9])} $body "\\1\x81\\2" body - while {[regsub -- -- $body "-{}-" body]} {} - regsub -all "\x80" $body --- body - regsub -all "\x81" $body -- body - # TeX does not use a standard encoding. Damn! - regsub -all "\xa9" $body {(c)} body - regsub -all "\xe1" $body {\'{a}} body - regsub -all "\xe9" $body {\'{e}} body - regsub -all "\xef" $body {\"{\i}} body - regsub -all "\xf1" $body {\~{n}} body - regsub -all "\xf3" $body {\'{o}} body - regsub -all "\xf4" $body {\^{o}} body - return $body - } - proc paragraph {body} { - global EmailRE URLRE TIPURLRE ShortTIPRE BASEURL ISSUEBASE ISSUEURLRE - variable mode - regsub -all $EmailRE $body "\x82\\1\x83" body - regsub -all $TIPURLRE $body "$BASEURL\\1.tex" body - regsub -all $ISSUEURLRE $body "$ISSUEBASE\\1" body - regsub -all {\\} $body {\(\backslash\)} body - regsub -all {([{}])} $body {\\\1} body - regsub -all {'''(('?[^'])+)'''} $body "\x89\\textbf{\\1}" body - regsub -all {''(('?[^'\x89])+)''} $body "\\textit{\\1}" body - regsub -all \x89 $body {} body - regsub -all {''+} $body {\(&\)} body - regsub -all "\"(\[^\"\]+)\"" $body "``\\1''" body - - set txt $body - set body {} - while {[regexp -indices $URLRE $txt match]} { - foreach {f t} $match {} - set pre [string range $txt 0 [expr {$f-1}]] - set url [string range $txt $f $t] - set post [string range $txt [expr {$t+1}] end] - regsub -all ~ $url "\x84" url - regsub -all & $url "\x85" url - regsub -all _ $url "\x86" url - append body $pre "\\url{" $url "}" - set txt $post - } - append body $txt - - regsub -all {\[\[} $body \x87 body - regsub -all {\]\]} $body \x88 body - switch $mode { - one { - regsub -all $ShortTIPRE $body "\\cite{tip\\1}" body - } - all { - regsub -all $ShortTIPRE $body \ - "\\hyperlink{tip\\1}{TIP ##\\1}" body - } - default { - error "unknown mode \"$mode\"" - } - } - - set body [quote $body] - while {[regsub "(\x82\[^\x82\x83\]*)\\\\_(\[^\x82\x83\]*\x83)" $body \ - {\1_\2} body]} { - # Underscores must not be quoted inside a \tipmail command - } - regsub -all "\x82(\[^ @\x82\x83]+)@(\[^ @\x82\x83]+)\x83" $body \ - "\\tipmail{\\1}{\\2}" body - regsub -all "\x84" $body ~ body - regsub -all "\x85" $body \\& body - regsub -all "\x86" $body _ body - regsub -all "\x87" $body \[ body - regsub -all "\x88" $body \] body - puts $body - # now, we need to find the citations made... - variable citations - while {[regexp -indices {\\cite{tip([0-9]+)}} $body -> idxpair]} { - foreach {x y} $idxpair {} - set cite [string range $body $x $y] - set body [string range $body $y end] - set citations($cite) 1 - } - } - - variable contexts {} - proc closecontext {} { - variable contexts - foreach c $contexts { - puts "\\end{$c}" - } - puts "" - set contexts {} - } - proc closetolevel {level} { - variable contexts - while {[llength $contexts] > $level} { - set c [lindex $contexts 0] - set contexts [lrange $contexts 1 end] - puts "\\end{$c}" - } - } - proc startcontext {type} { - variable contexts - set contexts [linsert $contexts 0 $type] - puts "\\begin{$type}" - } - proc changecontext {type} { - variable contexts - set cold [lindex $contexts 0] - if {[string compare $type $cold]} { - puts "\\end{$cold}\n\\begin{$type}" - set contexts [lreplace $contexts 0 0 $type] - } - } - proc liststart {level type} { - closetolevel [incr level] - variable contexts - if {[llength $contexts] == $level} { - changecontext $type - } else { - startcontext $type - } - } - - proc bulleting {level body} { - liststart $level itemize - puts "\\item{}" - paragraph $body - } - proc description {tag level body} { - liststart $level description - puts "\\item\[[quote $tag 1]\]" - paragraph $body - } - proc enumeration {tag level body} { - liststart $level enumerate - if {$tag != 1} { - incr tag -1 - set d 0 - variable contexts - foreach c $contexts {if {![string compare $c enumerate]} {incr d}} - switch $d { - 1 {puts "\\setcounter{enumi}{$tag}"} - 2 {puts "\\setcounter{enumii}{$tag}"} - 3 {puts "\\setcounter{enumiii}{$tag}"} - 4 {puts "\\setcounter{enumiv}{$tag}"} - } - } - puts "\\item{}" - paragraph $body - } - proc continuation {level body} { - variable contexts - if {[llength $contexts] == 0 && $level == 1} { - puts "\n\\begin{quote}" - paragraph $body - puts "\\end{quote}" - return - } - closetolevel $level - puts "" - paragraph $body - } - - proc section {title {level 1}} { - variable idxnum - closecontext - set cmd {} - for {set i 1} {$i<$level} {incr i} {append cmd sub} - puts "\\[append cmd section]{[quote $title 1]}" - } - proc image {bodytext} { - global ImageRE DOCDIR BASEURL - variable idxnum - regexp $ImageRE [string trim $bodytext] -> url caption - closecontext - puts "\\begin{figure}\[htbp\]\\begin{center}\\leavevmode" - if { - [regexp {^[-_a-zA-Z0-9]+$} $url] && - [file exists [set fn [file join $DOCDIR $url.eps]]] - } then { - puts "\\tipimage{$url}{[::imwidth::getImageWidth $fn]pt}" - } else { - puts "\\fbox{\\tiny\\url{$url}}" - } - puts "\\caption{[quote $caption 1]}" - puts "\\end{center}\\end{figure}" - } - proc ordinary {body} { - closecontext - paragraph $body - } - proc separator {} { - closecontext - puts "\\vspace{3ex}\\hrule\\vspace{1.5ex}" - } - proc verbatim {lines} { - puts "\\begingroup\\small\\begin{verbatim}" - foreach line $lines { - # Ugh! LaTeX chokes on formfeed characters in verbatim, - # which tend to be common in quoted patches to the core... - regsub -all { } $line ^L line - puts $line - } - puts "\\end{verbatim}\n\\endgroup" - } - proc shorten {length string} { - if {$length+2 >= [string length $string]} {return $string} - return [string range $string 0 $length]. - } - proc index {kind {errorKind soft}} { - closecontext - switch -- $kind { - short { - foreachTIP d { - set num "TIP #$d(TIP):" - switch $d(State) { - Draft - Rejected - Withdrawn { - set state "(\\emph{$d(State)})" - } - default {set state ""} - } - puts "[quote $num] $state" - paragraph $d(Title) - puts "" - } - } - medium { - puts "\\begin{center}\\begin{supertabular}{c|ll|p{2.5in}}" - puts "\\textbf{TIP ID}&\\textbf{Type}&\\textbf{State}&\ - \\textbf{Title}\\\\\\hline" - foreachTIP d { - puts -nonewline "\\small TIP \\#$d(TIP)&\\small\ - [shorten 5 $d(Type)]&\\small\ - [shorten 4 $d(State)]&\\small " - paragraph $d(Title) - puts -nonewline "\\\\" - } - puts "\\end{supertabular}\\end{center}" - } - long { - puts "\\begin{center}\\begin{supertabular}{|lp{3.3in}|}\\hline" - set docsep "" - foreachTIP d { - puts $docsep - puts -nonewline "\\textbf{TIP \\#$d(TIP)}:&" - puts "\\textbf{[quote $d(Title)]}\\\\" - puts "Version:&\\tipversion$d(Version)\\\\" - - regsub -all "\t" $d(Author) " " authorNotab - if {[llength $d(Author)] == 1} { - puts -nonewline "Author:&" - paragraph [lindex $authorNotab 0] - puts "\\\\" - } else { - puts -nonewline "Authors:&" - paragraph [lindex $authorNotab 0] - foreach a [lrange $authorNotab 1 end] { - puts -nonewline "\\par " - paragraph $a - } - puts "\\\\" - } - - puts "State:&$d(State)\\\\Type:&$d(Type)\\\\" - if {[info exist d(Tcl-Version)]} { - puts "Tcl Version:&$d(Tcl-Version)\\\\" - } - puts "Vote:&$d(Vote)\\\\" - puts [clock format $d(Created) -gmt 1 \ - -format "Created:&%d %B %Y\\\\"] - puts "Posting History:&" - set ph "" - foreach event [split $d(Post-History) ","] { - puts $ph[quote [string trim $event]] - set ph "\\par " - } - puts "\\\\" - if {[info exist d(Discussions-To)]} { - regsub -all {,} $d(Discussions-To) {, } dt - puts "Discussions To:&[quote $dt]\\\\" - } - if {[info exist d(Obsoletes)]} { - puts "Obsoletes:&TIP \\#$d(Obsoletes)\\\\" - } - if {[info exist d(Obsoleted-By)]} { - puts "Obsoleted By:&TIP \\#$d(Obsoleted-By)\\\\" - } - if {[info exist d(Vote-By)]} { - if {$d(Vote-By) > [clock seconds]} { - set inf "" - } else { - set inf " (closed)" - } - puts [clock format $d(Vote-By) -gmt 1 \ - -format "Vote By:&%d %B %Y, %H:%M GMT$inf\\\\"] - } - if {[info exist d(Votes-For)]} { - puts "Votes For:&$d(Votes-For)\\\\" - } - if {[info exist d(Votes-Against)]} { - puts "Votes Against:&$d(Votes-Against)\\\\" - } - if {[info exist d(Votes-Abstained)]} { - puts "Votes Abstained:&$d(Votes-Abstained)\\\\" - } - if {[info exist d(Keywords)]} { - puts "Keywords:&[quote [join $d(Keywords) {, }]]\\\\" - } - puts "&\\\\Abstract:&" - paragraph $d(Abstract) - set docsep "\\\\\\hline\\hline" - } - puts "\\\\\\hline\\end{supertabular}\\end{center}" - } - default { - puts "\\fbox{\\textbf{Index ``$kind'' not yet supported}}" - } - } - } - - proc generateDocumentHeader {headerArrayName {emptyPage 1} {targ {}}} { - upvar $headerArrayName h - - puts "\\begin{center}\\begin{tabularx}{\\linewidth}{|r@{: }X|}\\hline" - if {[string length $targ]} { - puts [format {\hypertarget{%s}{\textbf{%s}}&\textbf{%s}\\\hline} \ - $targ [quote "TIP #$h(TIP)" 1] [quote $h(Title) 1]] - } else { - puts [format "\\textbf{%s}&\\textbf{%s}\\\\\\hline" \ - [quote "TIP #$h(TIP)" 1] [quote $h(Title) 1]] - } - puts [quote Author 1]& - set sep "" - foreach a $h(Author) { - puts $sep; set sep "\\par" - paragraph $a - } - puts "\\\\" - set d [clock format $h(Created) -gmt 1 -format %d] - switch $d { - 01 - 21 - 31 { set ord st } - 02 - 22 { set ord nd } - 03 - 23 { set ord rd } - default { set ord th } - } - set d [string trimleft $d 0] - puts [clock format $h(Created) -gmt 1 -format \ - "Created&%A, \\(\\text{$d}^{\\text{$ord}}\\) %B %Y\\\\"] - puts "Type&$h(Type)\\\\" - if {[info exist h(Tcl-Version)]} { - regsub a $h(Tcl-Version) \\alpha h(Tcl-Version) - regsub b $h(Tcl-Version) \\beta h(Tcl-Version) - puts "Tcl Version&\\($h(Tcl-Version)\\)\\\\" - unset h(Tcl-Version) - } - puts "State&$h(State)\\\\" - puts "Vote&$h(Vote)\\\\" - puts "Version&\\tipversion$h(Version)\\\\" - if {[info exist h(Keywords)]} { - puts "Keywords&[quote [join $h(Keywords) {, }] 1]\\\\" - unset h(Keywords) - } - if {[info exist h(Vote-By)]} { - if {$h(Vote-By) > [clock seconds]} { - set inf "" - } else { - set inf " (closed)" - } - puts [clock format $h(Vote-By) -gmt 1 \ - -format "Vote By:&%d %B %Y, %H:%M GMT$inf\\\\"] - unset h(Vote-By) - } - - unset h(TIP) h(Title) h(Author) h(Created) - unset h(Version) h(Type) h(State) h(Vote) - # Do any fields I've forgotten! - foreach {key val} [array get h] { - regsub -all -- {-} $key { } key - puts [format {%s&%s\\} [quote $key 1] [quote $val 1]] - } - puts "\\hline\\end{tabularx}\\end{center}" - if {$emptyPage} {puts "\\thispagestyle{empty}\\pagestyle{empty}"} - } - - proc generateDocRefs {{reflevel section}} { - global PUBLISHURL DOCDIR - variable citations - if {[array size citations]} { - puts "\\begin{thebibliography}{TIP \\#[array size citations]}" - puts "\\addcontentsline{toc}{$reflevel}{References}" - foreach cite [lsort -dictionary [array names citations]] { - array set dtl [getTIPDetails [file join $DOCDIR $cite.tip]] - puts "\\bibitem\[TIP \\#$cite\]{tip$cite}" - foreach a $dtl(Author) { - regsub {<.*} $a {} a - puts "[quote [string trim $a] 1]," - } - puts "\\emph{[quote $dtl(Title) 1]}," - puts "on-line at \\url{$PUBLISHURL/$cite.html}" - unset dtl - } - puts "\\end{thebibliography}" - } - } - - # The static part of the header, used to define things that would - # otherwise be extremely backslash-heavy. - variable tipdefs { - \urlstyle{sf} - \setlength{\parskip}{1ex} - \setlength{\parindent}{0pt} - \def\tipversion$#1${\texttt{\$#1\$}} - \def\tiplangle#1{\ensuremath{<}} - \def\tiprangle#1{\ensuremath{>}} - \def\tipbar#1{\ensuremath{|}} - \def\tipmail#1#2{\(\langle\){\small\expandafter\url{#1@#2}}\(\rangle\)} - \ifx\pdfoutput\undefined - \newcommand{\tipimage}[2]{% - \typeout{Make sure you download #1.eps}\ifthenelse{% - \lengthtest{0.8\textwidth>#2}\and\lengthtest{0pt<#2}}{% - \includegraphics{#1.eps}}{% - \includegraphics[width=0.8\textwidth]{#1.eps}}} - \newcommand{\tipxref}[1]{} - \newcommand{\tipxrefend}{} - \else - \newcommand{\tipimage}[2]{% - \typeout{Make sure you create #1.pdf}\ifthenelse{% - \lengthtest{0.8\textwidth>#2}\and\lengthtest{0pt<#2}}{% - \includegraphics{#1.pdf}}{% - \includegraphics[width=0.8\textwidth]{#1.pdf}}} - \pdfcatalog{/PageMode /UseOutlines} - \newcommand{\tipxref}[1]{\pdfannotlink % - attr {/C [0.5 0.5 1.0] /Border [0 0 1]} % - goto name {#1}} - \newcommand{\tipxrefend}{\pdfendlink} - \fi - \newenvironment{tipabstract}{% - \begin{abstract}}{\end{abstract}} - } - - proc generateLaTeXPreamble {title author {date {}} {class article}} { - global env - variable tipdefs - set ltxopts {} - set ltxpkg {} - if {[info exist env(LATEXOPTS)]} { - set ltxopts [split $env(LATEXOPTS) ,] - } - #set ltxopts [linsert $ltxopts 0 dvips] - if {[info exist env(LATEXPACKAGES)]} { - set ltxpkg [split $env(LATEXPACKAGES) ,] - } - set ltxpkg [linsert $ltxpkg 0 \ - amsmath graphicx supertabular hyperref tabularx ifthen] - puts "\\documentclass\[[join $ltxopts ,]\]{$class}" - puts "\\usepackage{[join $ltxpkg ,]}" - puts "\\title{[quote $title 1]}" - if {[string length $date]} { - puts "\\date{[quote $date 1]}" - } - puts "\\author{[quote $author 1]}" - regsub -all "\n\[ \t]+" [string trim $tipdefs] "\n" strippedTD - regsub -all "%\n" $strippedTD {} strippedTD - puts $strippedTD - puts "\\begin{document}\\maketitle" - } - - proc generateDocument {head body} { - global FOOTERTEXT - variable mode one - array set h $head - - set authors {} - set sep "" - foreach a $h(Author) { - regsub -all "\[ \t\]*<.*" $a "" a - append authors "$sep$a" - set sep ", " - } - - generateLaTeXPreamble "TIP #$h(TIP): $h(Title)" $authors \ - [clock format $h(Created) -gmt 1 -format "%B %d, %Y"] - - generateDocumentHeader h - puts "\\begin{tipabstract}" - eval [intuitParagraphKind [lindex $body 1]] - puts "\\end{tipabstract}" - - puts "\\tableofcontents\\setcounter{page}{0}\\clearpage\\pagestyle{plain}" - foreach par [lrange $body 2 end] { - eval [intuitParagraphKind $par] - } - section "Colophon" - ordinary ''$FOOTERTEXT'' - generateDocRefs - puts "\\end{document}" - } - - variable imageURLCache - array set imageURLCache {} - proc getImageURLs {tipNumber} { - global DOCDIR - variable imageURLCache - if {[info exist imageURLCache($tipNumber)]} { - return $imageURLCache($tipNumber) - } - set images {} - if {$tipNumber == "all"} { - foreach tip [getTIPFilenames] { - array set dtl [getTIPDetails $tip] - foreach par $dtl(Body) { - set cmd [intuitParagraphKind $par] - if {[lindex $cmd 0] == "image"} { - lappend images [lindex $cmd 1] - } - } - } - } else { - array set dtl [getTIPDetails [file join $DOCDIR $tipNumber.tip]] - foreach par $dtl(Body) { - set cmd [intuitParagraphKind $par] - if {[lindex $cmd 0] == "image"} { - lappend images [lindex $cmd 1] - } - } - } - set imageURLCache($tipNumber) $images - } - proc linkEPSImagesForDocument {tipNumber targetDir} { - foreach url [getImageURLs $tipNumber] { - if { - [regexp {^[-_a-zA-Z0-9]+$} $url] && - [file exists [set src [file join $DOCDIR $url.eps]]] - } - if {![file exists [set dst [file join $targetDir $url.eps]]]} { - exec ln -s $src $dst - } - } - } - proc makePDFImagesForDocument {tipNumber targetDir} { - set urls [getImageURLs $tipNumber] - linkEPSImagesForDocument $tipNumber $targetDir - foreach url $urls { - if { - ![regexp {^[-_a-zA-Z0-9]+$} $url] || - ![file exists [set src [file join $targetDir $url.eps]]] - } { - continue - } - set dst [file join $targetDir $url.pdf] - if {[file exists $dst] && [file mtime $dst]>[file mtime $src]} { - continue - } - epstopdf::epstopdf $src $dst - } - } - - proc generateWholeArchive {} { - variable mode all - variable idxnum - variable citations - set tips [getTIPFilenames] - set t1 [file rootname [file tail [lindex $tips 0]]] - set tn [file rootname [file tail [lindex $tips end]]] - generateLaTeXPreamble \ - [format {Tcl Improvement Proposals: TIPs %d--%d} $t1 $tn] \ - {The Tcl Community} {} report - puts "\\renewcommand{\\bibname}{References}" - puts "\\renewcommand{\\chaptername}{TIP \\#}" - puts "\\addtocounter{chapter}{-1}" - puts "\\tableofcontents\\listoffigures" - - foreach tip $tips { - ::puts -nonewline stderr \[ - set pars [splitIntoParagraphs [getTIPFileContents $tip]] - array set h [verifyTIPheader \ - [splitRFC822Header [lindex $pars 0]]] - set kinds {} - foreach par [lrange $pars 2 end] { - lappend kinds [intuitParagraphKind $par] - } - - ::puts -nonewline stderr $h(TIP) - puts "\\chapter{[quote $h(Title) 1]}" - generateDocumentHeader h 0 tip$h(TIP) - puts "\\section{Abstract}" - eval [lindex $kinds 0] - puts "\\clearpage" - unset h - foreach par [lrange $kinds 1 end] { eval $par } - closecontext - ::puts -nonewline stderr "\] " - } - ::puts stderr "" - if {[array size citations]} { - puts "\\clearpage" - set idx [incr idxnum] - puts "\\ifx\\pdfoutput\\undefined\\relax\\else\\pdfdest\ - num $idx xyz\\pdfoutline goto num $idx {References}\\fi" - generateDocRefs chapter - } - puts "\\end{document}" - } -} DELETED tiptxt.tcl Index: tiptxt.tcl ================================================================== --- tiptxt.tcl +++ /dev/null @@ -1,380 +0,0 @@ -namespace eval tiptxt { - proc fmtPar {firsthead nexthead body} { - puts "" - set str "" - set body "$firsthead $body" - # Apply standard transformations here... - global URLRE TIPURLRE ShortTIPRE BASEURL ISSUEBASE ISSUEURLRE - regsub -all $TIPURLRE $body "$BASEURL\\1.txt" body - regsub -all $ISSUEURLRE $body "$ISSUEBASE\\1" body - regsub -all $URLRE $body "" body - regsub -all {\[\[} $body \x80 body - regsub -all {\]\]} $body \x81 body - regsub -all $ShortTIPRE $body "\[TIP #\\1\]" body - regsub -all ''' $body {*} body - regsub -all '' $body {/} body - regsub -all \x80 $body \[ body - regsub -all \x81 $body \] body - foreach word [split $body] { - if {[string length $str$word] > 72} { - puts $str - set str "$nexthead " - } - append str $word " " - } - puts $str - } - - variable counters {} - proc manageListCounters {level num} { - variable counters - if { - [regexp {^1$} $num] && - $level < [llength $counters] && - [lindex $counters $level] != "*" - } then { - set num [lindex $counters $level] - incr num - } - set counters [lrange [linsert $counters $level $num] 0 $level] - return [lindex $counters end] - } - proc setupIndents {level {msg ""}} { - format "%*s" [expr {$level>=0?($level+1)*7-1:0}] $msg - } - - proc bulleting {level body} { - manageListCounters $level * - set ind [setupIndents $level] - regsub {.$} $ind * ind1 - fmtPar $ind1 $ind $body - } - proc description {tag level body} { - set tag " ${tag}:" - set body [string trim $body] - manageListCounters $level * - set ind1 [setupIndents [expr {$level-1}]] - set ind [setupIndents $level] - set tagspace [expr {[string length $ind]-[string length $ind1]}] - if {$tagspace*2 < [string length $tag]} { - puts -nonewline \n$ind1$tag - fmtPar $ind $ind $body - } elseif {$tagspace < [string length $tag]} { - fmtPar $ind1$tag $ind $body - } else { - fmtPar [format %s%-*s $ind1 $tagspace $tag] $ind $body - } - } - proc enumeration {tag level body} { - set indt [setupIndents $level [manageListCounters $level $tag].] - set inds [setupIndents $level] - fmtPar $indt $inds $body - } - proc continuation {level string} { - set indent [setupIndents [expr {$level-1}]] - fmtPar $indent $indent $string - } - proc ordinary {string} { - variable counters {} - continuation -1 $string - } - - proc section {title {level 1}} { - variable counters {} - switch $level { - 1 { - regsub -all . $title = uline - puts "\n [string toupper $title] \n=$uline=" - } - 2 { - regsub -all . $title - uline - puts "\n [string toupper $title] \n-$uline-" - } - 3 { - puts "\n [string toupper $title] " - } - default { - regsub -all " " $title _ title - puts "\n_$title_" - } - } - } - proc separator {} { - variable counters {} - puts -nonewline "\n------------------------------" - puts "-------------------------------------------" - } - proc verbatim {lines} { - # It's actually quite awkward, since we have to convert tabs to spaces - puts "" - foreach line $lines { - set bits [split $line \t] - set txt [lindex $bits 0] - foreach bit [lrange $bits 1 end] { - append txt " " - while {[string length $txt] % 8} {append txt " "} - append txt $bit - } - puts " $txt" - } - } - proc centre {lines} { - puts "" - set untabbed {} - set width 0 - foreach line $lines { - set bits [split $line \t] - set txt [lindex $bits 0] - foreach bit [lrange $bits 1 end] { - append txt " " - while {[string length $txt] % 8} {append txt " "} - append txt $bit - } - lappend untabbed $txt - if {[string length $txt]>$width} {set width [string length $txt]} - } - if {$width >= 70} { - foreach line $untabbed { - puts $line - } - } else { - set ind [expr {(72-$width)/2}] - foreach line $untabbed { - puts [format %*s%s $ind "" $line] - } - } - } - proc image {bodytext} { - variable counters {} - global ImageRE - if { - [regexp $ImageRE $bodytext -> url caption] && - [regexp {^[-_a-zA-Z0-9]+$} $url] - } then { - global DOCDIR - set fn [file join $DOCDIR $url.txt] - if {[file isfile $fn] && [file readable $fn]} { - set f [open $fn r] - set lines [split [read -nonewline $f] "\n"] - close $f - centre $lines - centre [list $caption] - return - } - } elseif {[info exist url] && [info exist caption]} { - centre [list "" ] - centre [list $caption] - } else { - centre [list "<<$bodytext>>"] - } - } - proc index {kind {errorKind soft}} { - variable counters {} - switch $kind { - short { - puts "" - foreachTIP d { - puts -nonewline " TIP #$d(TIP):" - switch $d(State) { - Draft - Rejected { - puts -nonewline " ([string index $d(State) 0])" - } - default { - puts -nonewline " " - } - } - puts " $d(Title)" - } - } - medium { - array set w {1 9 2 4 3 5 4 5} - foreachTIP d { - foreach {name col i} { - TIP 1 5 - Type 2 0 - State 3 0 - Title 4 0 - } { - if {[string length $d($name)] > $w($col)+$i} { - set w($col) [expr {[string length $d($name)]+$i}] - } - } - } - puts "" - set format "| %-$w(1)s | %-$w(2)s | %-$w(3)s | %-$w(4)s |" - set sep [format $format " " " " " " " "] - regsub -all " " $sep - sep - regsub -all "\[|\]" $sep + sep - puts $sep - puts [format $format "Series ID" "Type" "State" "Title"] - puts $sep - foreachTIP d { - puts [format $format "TIP #$d(TIP)" \ - $d(Type) $d(State) $d(Title)] - } - puts $sep - } - long { - foreachTIP d { - puts "" - set rows {} - lappend rows "TIP #$d(TIP):" $d(Title) - lappend rows Version: $d(Version) - regsub -all "\t" $d(Author) " " authorNotab - if {[llength $d(Author)] == 1} { - regsub @ [lindex $authorNotab 0] _at_ a - lappend rows Author: $a - } else { - regsub @ [lindex $authorNotab 0] _at_ a - lappend rows Authors: $a - foreach a [lrange $authorNotab 1 end] { - regsub @ $a _at_ a - lappend rows "" $a - } - } - lappend rows State: $d(State) Type: $d(Type) - if {[info exist d(Tcl-Version)]} { - lappend rows "Tcl Version:" $d(Tcl-Version) - } - lappend rows Vote: $d(Vote) - lappend rows Created: [clock format $d(Created) \ - -format "%d %b %Y" -gmt 1] - set ph "Posting History:" - foreach event [split $d(Post-History) ","] { - lappend rows $ph [string trim $event] - set ph "" - } - if {[info exist d(Discussions-To)]} { - set dt [join [split $d(Discussions-To) ,] ", "] - regsub -all -- { +} $dt { } dt - lappend rows "Discussions To:" $dt - } - if {[info exist d(Obsoletes)]} { - lappend rows Obsoletes: "TIP #$d(Obsoletes)" - } - if {[info exist d(Obsoleted-By)]} { - lappend rows "Obsoleted By:" "TIP #$d(Obsoleted-By)" - } - if {[info exist d(Vote-By)]} { - if {$d(Vote-By) > [clock seconds]} { - lappend rows Vote-By: [clock format $d(Vote-By) \ - -format "%d %b %Y, %H:%M GMT" -gmt 1] - } else { - lappend rows Vote-By: [clock format $d(Vote-By) \ - -format "%d %b %Y, %H:%M GMT (closed)" \ - -gmt 1] - } - } - if {[info exist d(Votes-For)]} { - lappend rows "Votes For:" $d(Votes-For) - } - if {[info exist d(Votes-Against)]} { - lappend rows "Votes Against:" $d(Votes-Against) - } - if {[info exist d(Votes-Abstained)]} { - lappend rows "Votes Abstained:" $d(Votes-Abstained) - } - if {[info exist d(Keywords)]} { - lappend rows Keywords: [join $d(Keywords) ", "] - } - set width 1 - foreach {tag ?} $rows { - if {[string length $tag]>$width} { - set width [string length $tag] - } - } - foreach {tag val} $rows { - puts [format "%-*s %s" $width $tag $val] - } - set indent [format "%*s" $width ""] - fmtPar $indent $indent $d(Abstract) - } - } - default { - if {[string compare $errorKind soft]} { - return -code error "Index style $kind not supported" - } - set msg "*Index style \"$kind\" bit yet supported*" - regsub -all . $msg * stars - centre [list $stars $msg $stars] - } - } - } - - proc generateDocument {head body {extra {}}} { - global BASEURL - array set header $head - section "TIP #$header(TIP): $header(Title)" - set lines [list Version: $header(Version)] - set indent 8 - if {[info exist header(Author)]} { - set at Author: - foreach a $header(Author) { - regsub @ $a _at_ a - lappend lines $at $a - set at "" - } - } - foreach h {State Type Tcl-Version Vote} { - if {[info exist header($h)]} { - lappend lines ${h}: $header($h) - if {[string length $h]+1>$indent} { - set indent [expr {[string length $h]+1}] - } - } - } - lappend lines Created: [clock format $header(Created) \ - -format {%A, %d %B %Y} -gmt 1] - if {[string compare [lindex $extra 0] URL]} { - lappend lines URL: $BASEURL$header(TIP).html - } - foreach {key value} $extra {lappend lines ${key}: $value} - if {[info exist header(Discussions-To)]} { - set h Discussions-To: - foreach dt [split $header(Discussions-To) ","] { - lappend lines $h [string trim $dt] - if {[string length $h]>$indent} { - set indent [string length $h] - } - set h "" - } - } - if {[info exist header(Post-History)]} { - lappend lines Post-History: $header(Post-History) - if {[string length Post-History]+1>$indent} { - set indent [expr {[string length Post-History]+1}] - } - } - foreach h {Obsoletes Obsoleted-By} { - if {[info exist header($h)]} { - lappend lines ${h}: "TIP #$header($h)" - if {[string length $h]+1>$indent} { - set indent [expr {[string length $h]+1}] - } - } - } - if {[info exist header(Vote-By)]} { - lappend lines Vote-By: [clock format $header(Vote-By) -gmt 1 \ - -format {%A, %d %B %Y, %H:%M GMT}] - } - foreach h {Votes-For Votes-Against Votes-Abstained} { - if {[info exist header($h)]} { - lappend lines ${h}: $header($h) - if {[string length $h]+1>$indent} { - set indent [expr {[string length $h]+1}] - } - } - } - foreach {key value} $lines { - regsub -all "\t" $value " " value - puts [format " %-*s %s" $indent $key $value] - } - separator - foreach par $body { - eval [intuitParagraphKind $par] - } - separator - global FOOTERTEXT - ordinary $FOOTERTEXT - } -} DELETED tipview.tcl Index: tipview.tcl ================================================================== --- tipview.tcl +++ /dev/null @@ -1,182 +0,0 @@ -namespace eval tipview { - proc section {title {level 1}} { - variable w - $w insert end $title\n section$level - } - proc formattedInsert {string tag} { - variable w - regsub -all {'''(('?[^'])+)'''} $string \x81\\1\x81 string - regsub -all {''(('?[^'])+)''} $string \x80\\1\x80 string - set idx [$w index end] - $w insert end $s\n $tag - while {1} { - set idx [$w search -regexp "\x80|\x81" $idx end] - if {$idx eq ""} break - set c [$w get $idx] - set idx2 [$w search -exact $c $idx+1c end] - switch [$w get $idx] { - \x80 {$w tag add ${tag}_i $idx $idx2} - \x81 {$w tag add ${tag}_b $idx $idx2} - } - $w delete $idx2 - $w delete $idx - } - } - proc ordinary {string} { - formattedInsert $string plain - } - proc bulleting {level body} { - formattedInsert *\t$body list[expr {$level+1}] - } - proc description {tag level body} { - formattedInsert ${tag}:\t$body list[expr {$level+1}] - } - proc enumeration {tag level body} { - formattedInsert $tag.\t$body list[expr {$level+1}] - } - proc continuation {level body} { - formattedInsert $body cont$level - } - proc separator {} { - variable w - variable sep - if {![info exist sep]} { - set wide [expr {[winfo reqwidth $w]-25}] - set sep [::image create photo -width $wide -height 1] - $sep put black -to 0 0 $wide 1 - } - $w image create end -image $sep -padx 5 -pady 5 - $w insert end \n - } - proc verbatim {lines} { - variable w - $w insert end \n[join $lines \n]\n\n verbatim - } - proc index {kind} { - variable w - $w insert end "Index $kind not supported by this renderer\n" - } - proc image {bodytext} { - variable w - if {[regexp {^([^./ ]+) +(.*)} $bodytext -> f caption]} { - global DOCDIR - set f [file join $DOCDIR $f.gif] - if {[file exist $f]} { - variable img - if {![info exist img($f)]} { - set wide [expr {[winfo reqwidth $w]-25}] - set img($f) [::image create photo -file $f] - while {[::image width $img($f)] > $wide} { - set i [::image create photo] - $i copy $img($f) -subsample 2 2 - ::image delete $img($f) - set img($f) $i - } - } - $w image create end -image $img($f) -padx 5 -pady 5 - $w insert end \n {} $caption caption \n - return - } - } - $w insert end "Image $bodytext not supported by this renderer\n" - } - - proc generateTIPHeader {hName w} { - upvar 1 $hName h - set l $w.top - set hi [expr {[array size h]-1+[llength $h(Author)]}] - pack [text $l -height $hi -wrap word -font {Times -14}] \ - -side top -fill x -expand 1 - $l tag configure key -font {Times -14 bold} - set wide 1 - set font {Times -14 bold} - foreach n [array names h] { - set nw [font measure $font ${n}:] - if {$nw>$wide} {set wide $nw} - } - incr wide 4 - $l configure -tabs $wide - $l tag configure head -lmargin1 0 -lmargin2 $wide - array set done {TIP . Title . Author . Created .} - $l insert end TIP: {head key} \t$h(TIP)\n head - $l insert end Title: {head key} \t$h(Title)\n head - $l insert end Created: {head key} [clock format $h(Created) -gmt 1 \ - -format "\t%A %d %B %Y\n"] head - $l insert end Authors: {head key} "\t[join $h(Author) \n\t]\n" head - foreach n [lsort [array names h]] { - if {[info exist done($n)]} {continue} - $l insert end ${n}: {head key} \t$h($n)\n head - } - $l delete end-1c - $l configure -state disabled - } - proc viewTIP {tipnumber} { - global DOCDIR - set file [file join $DOCDIR $tipnumber.tip] - set data [getTIPFileContents $file] - set pars [splitIntoParagraphs $data] - set heads [verifyTIPheader [splitRFC822Header [lindex $pars 0]]] - set par1 [intuitParagraphKind [lindex $pars 1]] - array set h $heads - if {[string compare $par1 {section Abstract 1}]} { - return -code error "TIP $h(TIP) must start with abstract..." - } - - set t .t$h(TIP) - catch {destroy $t} - toplevel $t - wm title $t "TIP #$h(TIP): $h(Title)" - wm iconname $t "TIP #$h(TIP)" - - generateTIPHeader h $t - - variable w $t.bot - pack [text $w -wrap word] \ - -side top -fill both -expand 1 - - $w tag configure section1 -font {Helvetica -18 bold} \ - -lmargin1 1m -rmargin 1m -spacing1 1m -spacing3 1m - $w tag configure section2 -font {Helvetica -14 bold} \ - -lmargin1 1m -rmargin 1m -spacing1 1m -spacing3 1m - $w tag configure section3 -font {Helvetica -12 bold} \ - -lmargin1 1m -rmargin 1m -spacing1 1m -spacing3 1m - $w tag configure verbatim -font {Courier 10} - $w tag configure plain -font {Times 10} \ - -lmargin1 2m -lmargin2 2m -rmargin 2m -spacing3 1m - $w tag configure plain_i -font {Times 10 italic} - $w tag configure plain_b -font {Times 10 bold} - for {set i 1} {$i<5} {incr i} { - $w tag configure list$i -font {Times 10} \ - -lmargin1 [expr {$i*4+1}]m -lmargin2 [expr {$i*4+5}]m \ - -rmargin 2m -spacing3 1m -tabs 5m - $w tag configure list${i}_i -font {Times 10 italic} - $w tag configure list${i}_b -font {Times 10 bold} - $w tag configure cont$i -font {Times 10} \ - -lmargin1 [expr {$i*4+5}]m -lmargin2 [expr {$i*4+5}]m \ - -rmargin 2m -spacing3 1m - $w tag configure cont${i}_i -font {Times 10 italic} - $w tag configure cont${i}_b -font {Times 10 bold} - } - - # generate HTML body - foreach par [lrange $pars 1 end] { - eval [intuitParagraphKind $par] - } - } -} - -if {![string compare [file join [pwd] $::argv0] [file join [pwd] [info script]]]} { - # test mode! - set SRCDIR [file dirname [file join [pwd] [info script]]] - source $SRCDIR/config.tcl - source $SRCDIR/parse.tcl - - package require Tk - pack [listbox .l -width 5 -yscroll {.s set}] \ - [scrollbar .s -orient vertical -command {.l yview}] \ - -side left -expand 1 -fill both - foreachTIP t { - .l insert end $t(TIP) - } - bind .l {tipview::viewTIP [.l get @%x,%y]} -} DELETED tipxml.tcl Index: tipxml.tcl ================================================================== --- tipxml.tcl +++ /dev/null @@ -1,345 +0,0 @@ -source $SRCDIR/base64.tcl -namespace eval tipxml { - variable section - variable sectype - variable secnum -1 - variable title - array set section {} - array set sectype {} - array set title {} - - proc makePCDATA {string} { - regsub -all & $string {\&} string - regsub -all < $string {\<} string - regsub -all > $string {\>} string - regsub -all ' $string {\'} string - regsub -all \" $string {\"} string - return $string - } - proc makeCDATAQ {string} { - # Ho hum, this does the right thing according to the Standard... - return [makePCDATA $string] - #regsub -all \" $string {\\&} string - #return $string - } - - proc makeTextContent {string} { - global URLRE EmailRE ShortTIPRE TIPURLRE ISSUEBASE ISSUEURLRE - set q \x82 - regsub -all $EmailRE $string "" string - regsub -all $ISSUEURLRE $string "$ISSUEBASE\\1" string - regsub -all $URLRE $string "\x80url ref=${q}&${q}/\x81" string - regsub -all {\[\[} $string \x83 string - regsub -all {\]\]} $string \x84 string - regsub -all "\\\[\x80url (\[^\x81\]\x81)\\\]" $string \ - "\x80url style=${q}compact${q} \\1" string - regsub -all {'''(('?[^'])+)'''} $string \ - "\x85\200emph style=${q}bold${q}\x81\\1\x80/emph\x81" string - regsub -all {''(('?[^'\x85])+)''} $string \ - "\200emph style=${q}italic${q}\x81\\1\x80/emph\x81" string - regsub -all $TIPURLRE $string \ - "\x80tipref type=${q}url${q} tip=${q}\\1${q}/\x81" string - regsub -all $ShortTIPRE $string \ - "\x80tipref type=${q}text${q} tip=${q}\\1${q}/\x81" string - regsub -all & $string {\&} string - regsub -all < $string {\<} string - regsub -all > $string {\>} string - regsub -all \" $string {\"} string - regsub -all ' $string {\'} string - regsub -all \x80 $string < string - regsub -all \x81 $string > string - regsub -all \x82 $string \" string - regsub -all \x83 $string \[ string - regsub -all \x84 $string \] string - regsub -all \x85 $string {} string - return $string - } - - variable curlev -1 - variable contexts {} - variable ctext - array set ctext {} - variable encounter - array set encounter {} - proc enterlistcontext {level good bad1 bad2} { - variable curlev - variable contexts - variable ctext - variable encounter - set result 0 - if {$level > $curlev} { - incr curlev - lappend contexts "" - set ctext($curlev) "<$good>" - set encounter($curlev) 0 - set result 1 - } - switch [lindex $contexts end] "" - "" { - set close [lindex $contexts end] - set closei [format "" [string index $close 2]] - append ctext($curlev) $closei $close < $good > - set encounter($curlev) 0 - set contexts [lreplace $contexts end end ""] - set result 1 - } - return $result - } - proc closecontext {{level -1}} { - variable curlev - variable contexts - variable ctext - variable encounter - while {$level < $curlev} { - set txt $ctext($curlev) - unset ctext($curlev) encounter($curlev) - set close [lindex $contexts end] - set closei [format "" [string index $close 2]] - if {[incr curlev -1] >= 0} { - append ctext($curlev) $txt $closei $close - set contexts [lrange $contexts 0 \ - [expr {[llength $contexts]-2}]] - } else { - variable section - variable secnum - lappend section($secnum) "$txt$closei$close" - set contexts [list] - return - } - } - } - - proc continuation {level body} { - variable curlev - variable ctext - variable section - variable secnum - - if {$curlev == -1} { - lappend section($secnum) "[makeTextContent $body]" - return - } - closecontext $level - append ctext($curlev) "" [makeTextContent $body] "" - } - proc bulleting {level body} { - closecontext $level - set flag [enterlistcontext $level itemize enumerate describe] - variable curlev - variable ctext - if {!$flag} { - append ctext($curlev) "" - } - append ctext($curlev) "" - continuation $level $body - } - proc enumeration {tag level body} { - closecontext $level - set flag [enterlistcontext $level enumerate itemize describe] - variable curlev - variable ctext - variable encounter - if {!$flag} { - append ctext($curlev) "" - } - if {$tag == 1} { - set tag [incr encounter($curlev)] - } else { - set encounter($curlev) $tag - } - append ctext($curlev) "" - continuation $level $body - } - proc description {tag level body} { - closecontext $level - set flag [enterlistcontext $level describe enumerate itemize] - variable curlev - variable ctext - if {!$flag} { - append ctext($curlev) "" - } - append ctext($curlev) "" - continuation $level $body - } - proc verbatim {lines} { - variable curlev - set l {} - foreach line $lines { - append l "" [B64encode $line] "" - } - if {$curlev >= 0} { - variable ctext - append ctext($curlev) "" $l "" - } else { - variable section - variable secnum - lappend section($secnum) "$l" - } - } - - ### FIXME! THIS IS *COMPLETELY* WRONG! ### - proc section {secttitle {level 1}} { - closecontext - variable section - variable secnum - variable sectype - variable title - set n [incr secnum] - set title($n) $secttitle - set section($n) {} - set sectype($n) $level - } - proc image {bodytext} { - global ImageRE - closecontext - variable section - variable secnum - set caption {} - regexp $ImageRE [string trim $bodytext] -> url caption - set caption [string trim $caption] - if {[string length $caption]} { - lappend section($secnum) \ - "" - } else { - lappend section($secnum) "" - } - } - proc index {kind} { - closecontext - variable section - variable secnum - lappend section($secnum) "" - } - proc separator {} { - closecontext - variable section - variable secnum - lappend section($secnum) "" - } - proc ordinary {string} { - closecontext - variable section - variable secnum - lappend section($secnum) "[makeTextContent $string]" - } - proc stag {level} { - return [lindex {"" "" sub subsub} $level]section - } - proc generateDocument {head body} { - global AuthorRE BASEURL FOOTERTEXT - array set h $head - puts "" - puts "" - puts "" - puts "\n\n" - puts -nonewline "
    [makePCDATA $h(Title)]" - foreach a $h(Author) { - regexp $AuthorRE $a -> name addr - set name [makePCDATA [string trim $name]] - set addr [makeCDATAQ mailto:$addr] - puts -nonewline "$name" - } - puts -nonewline "[makePCDATA $h(Version)]" - puts -nonewline "" - foreach e $h(Post-History) { - puts -nonewline "[makePCDATA $e]" - } - puts -nonewline "" - eval [clock format $h(Created) -gmt 1 -format {puts -nonewline \ - ""}] - if {[info exist h(Discussions-To)]} { - foreach dt [split $h(Discussions-To) ,] { - puts -nonewline \ - "" - } - } - if {[info exist h(Keywords)]} { - foreach k [split $h(Keywords) ,] { - puts -nonewline \ - "[makePCDATA [string trim $k]]" - } - } - if {[info exist h(Obsoletes)]} { - puts -nonewline "" - } - if {[info exist h(Obsoleted-By)]} { - puts -nonewline "" - } - if { - [info exist h(Vote-By)] || [info exist h(Votes-For)] || - [info exist h(Votes-Against)] || [info exist h(Votes-Abstained)] - } then { - if {[info exist h(Vote-By)]} { - puts -nonewline "" - } else { - puts -nonewline "" - } - if {[info exist h(Votes-For)]} { - puts -nonewline "" - } - if {[info exist h(Votes-Against)]} { - puts -nonewline "" - } - if {[info exist h(Votes-Abstained)]} { - puts -nonewline "" - } - puts -nonewline "" - } - puts "
    " - set abstractCmd [intuitParagraphKind [lindex $body 1]] - puts "[makeTextContent [lindex $abstractCmd 1]]" - puts -nonewline "" - - # Parse the paragraphs - foreach par [lrange $body 2 end] {eval [intuitParagraphKind $par]} - closecontext - # Now need to output the sections... - variable section - variable sectype - variable title - set level 0 - for {set i 0} {$i<[array size section]} {incr i} { - set l $sectype($i) - if {!$level} { - if {$l != 1} { - error "must have section before sub(sub)section" - } - } else { - if {$l-$level == 2} { - error "cannot generate a subsubsection in a section\ - without an intervening subsection" - } - while {$level>=$l} { - puts "" - incr level -1 - } - } - puts "<[stag $l] title=\"[makeCDATAQ $title($i)]\">" - puts [join $section($i) "\n"] - set level $l - } - while {$level>0} { - puts "" - incr level -1 - } - - puts "    " - } -}