#
# tkMOO
# ~/.tkMOO-lite/plugins/scoop.tcl
#
# tkMOO-light is Copyright (c) Andrew Wilson 1994,1995,1996,1997,1998,1999
# 2000,2001
#
# All Rights Reserved
#
# Permission is hereby granted to use this software for private, academic
# and non-commercial use. No commercial or profitable use of this
# software may be made without the prior permission of the author.
#
# THIS SOFTWARE IS PROVIDED BY ANDREW WILSON ``AS IS'' AND ANY
# EXPRESSED OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
# THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
# PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ANDREW WILSON BE LIABLE
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
# OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
# BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
# WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
# OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
# EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
client.register scoop start
client.register scoop incoming 10
proc scoop.start {} {
window.menu_tools_add "Scoop..." scoop.scoop_to_html
}
proc scoop.incoming event {
# generate a unique timestamp tag for this line now anything
# written which resulted from this line will carry the timestamp
set tag scoop_[clock seconds]
window.remove_matching_tags scoop_*
window.contribute_tags $tag
return [modules.module_deferred]
}
proc scoop.scoop {} {
# which lines are selected
set from ""
set to ""
catch {
set from [.output index {sel.first linestart}]
set to [.output index {sel.last - 1 char linestart}]
}
# was there a selection?
if { $from == "" } { return }
set scoop {}
# scan through the text looking for tags on the 1st character
for {set num $from} {$num <= $to} {set num [expr $num + 1.0]} {
set tags [.output tag names $num]
set time 000000000
regexp {scoop_([\-0-9]*)} $tags _ time
# one of these will be the timestamp...
set text [.output get $num "$num lineend"]
regsub "\n$" $text "" text
lappend scoop [list $time $text]
}
return $scoop
}
proc scoop.wrap_line {string num} {
set lines {}
set tmp ""
foreach word [split $string " "] {
if { [string length "$tmp $word"] < $num } {
append tmp "$word "
} {
lappend lines $tmp
set tmp "$word "
}
}
lappend lines $tmp
return $lines
}
proc scoop.scoop_to_html {} {
set scoop [scoop.scoop]
if { $scoop == {} } {
return
}
set html "\n\nScoop\n\n\n";
set start [lindex [lindex $scoop 0] 0]
append html "Scoop on [clock format $start]
\n"
set lines_list {}
foreach line [util.slice $scoop 1] {
foreach wrapped [scoop.wrap_line $line 70] {
lappend lines_list "$wrapped\n"
}
lappend lines_list "
\n"
}
set lines [join $lines_list {}]
# detect any URLs and turn them into links
regsub -all {(ftp|telnet|http)://([^\"\'\`\\)\(<> ]+)} $lines {\1://\2} lines
append html $lines
append html "";
set port [scoop.scoop_server $html]
set date [clock format [clock seconds] -format "%Y%m%d%H%M%S"]
webbrowser.open "http://127.0.0.1:$port/scoop.$date.html"
}
proc scoop.scoop_server html {
global scoop_html
global scoop_server_conn
set scoop_html $html
for {set port 9999} {$port < 9999+5} {incr port} {
set conn ""
catch { set conn [socket -server scoop.scoop_serve $port] }
if { $conn != "" } {
break
}
}
set scoop_server_conn $conn
return $port
}
proc scoop.scoop_serve {conn address port} {
global scoop_html scoop_server_conn
# read and ignore request headers
while { [gets $conn] != {} } { }
puts $conn "HTTP/1.0 200 Ok"
puts $conn "Content-type: text/html"
puts $conn "Content-length: [string length $scoop_html]"
puts $conn ""
puts $conn $scoop_html
close $conn
close $scoop_server_conn
set scoop_html ""
}