API tools faq
paste
Advertisement
Guest User

Untitled

a guest
Jul 18th, 2017
57
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
TCL 14.66 KB | None | 0 0
raw download clone embed print report
  1. ####################################################################
  2. #
  3. # File: util.tcl
  4. #
  5. # Description: Utility library of common functions
  6. #
  7. # Author: makk@EFnet
  8. #
  9. # Release Date: May 14, 2010
  10. #  Last Update: Jan 24, 2011
  11. #
  12. ####################################################################
  13.  
  14. package provide util 1.0
  15.  
  16. namespace eval ::util:: {
  17.     namespace export -clear loadDatabase s populate timeDiff toGMT toLocal now\
  18.         currentYear timezone DST formatShortDate formatDateTime formatWordDate\
  19.         formatWordDateTime put putMessage putNotice putAction mbind logStackable\
  20.         c /c b /b r /r u /u bindSQL scheduleBackup registerCleanup htmlDecode\
  21.         parseHTML geturlex
  22.  
  23.     variable ns [namespace current]
  24.     variable maxMessageLen 510
  25.     variable maxLineWrap   5  ;# max lines to wrap when text is too long
  26.     variable floodSupport  1
  27. }
  28.  
  29. proc ::util::loadDatabase {db database {sqlScripts {}}} {
  30.     global tcl_platform
  31.     variable ns
  32.  
  33.     foreach item [concat $database $sqlScripts] {
  34.         catch {exec chmod 600 $item}
  35.     }
  36.  
  37.     if {[catch {
  38.         if {$tcl_platform(platform) == "unix"} {
  39.             load "[pwd]/tclsqlite3.so" "tclsqlite3"
  40.         } else {
  41.             load "[pwd]/tclsqlite3.dll" "tclsqlite3"
  42.         }
  43.         sqlite3 $db $database
  44.     } error]} {
  45.         return -code error "*** Failed to open database '$database': $error"
  46.     }
  47.  
  48.     foreach script $sqlScripts {
  49.         if {[catch {set f [open $script r]} error]} {
  50.             return -code error "*** Failed to open SQL script '$script': $error"
  51.         } else {
  52.             catch {$db eval [read $f]}
  53.             catch {close $f}
  54.         }
  55.     }
  56.  
  57.     catch {$db function REGEXP ${ns}::regexpSQL}
  58.     return 1
  59. }
  60.  
  61. proc ::util::s {quantity {suffix "s"}} {
  62.     return [expr {$quantity == 1 ? "" : $suffix}]
  63. }
  64.  
  65. proc ::util::regexpSQL {expr text} {
  66.     if {[catch {set ret [regexp -nocase -- $expr $text]}]} {
  67.         # invalid expression
  68.         return 0
  69.     }
  70.     return $ret
  71. }
  72.  
  73. # add list placeholder support - ex: db eval [populate {SELECT * FROM t WHERE u IN(::var)}]
  74. proc ::util::populate {sql} {
  75.     set s ""
  76.     set pos 0
  77.     foreach {first last} [join [regexp -all -indices -inline {::[\w$]+} $sql]] {
  78.         append s [string range $sql $pos [expr $first - 1]]
  79.         set var [string range $sql [expr $first + 2] $last]
  80.         upvar $var list
  81.         if {[info exists list]} {
  82.             set varName "${var}$"
  83.             upvar $varName a
  84.             array unset a *
  85.             set items {}
  86.             set i 0
  87.             foreach item $list {
  88.                 set a($i) $item
  89.                 lappend items ":${varName}($i)"
  90.                 incr i
  91.             }
  92.             append s [join $items ,]
  93.         } else {
  94.             append s "NULL"
  95.         }
  96.         set pos [expr $last + 1]
  97.     }
  98.     return [append s [string range $sql $pos end]]
  99. }
  100.  
  101. # Some sort of Eggdrop/TCL bug results in clock changes not updating properly,
  102. # so we anchor at [unixtime] to be safe
  103.  
  104. proc ::util::timeDiff {date1 {future "away"} {past "ago"}} {
  105.     set secs [expr [clock scan $date1 -base [unixtime] -gmt 1] - [unixtime]]
  106.     set rel  [expr {$secs < 0 ? $past : $future}]
  107.     set secs [expr abs($secs)]
  108.     set days [expr $secs / (60 * 60 * 24)]
  109.     set secs [expr {$days ? 0 : $secs % (60 * 60 * 24)}]
  110.     set hrs  [expr $secs / (60 * 60)]
  111.     set secs [expr $secs % (60 * 60)]
  112.     set mins [expr $secs / 60]
  113.     set secs [expr {($hrs || $mins) ? 0 : $secs % 60}]
  114.     foreach {value unit} [list $days d $hrs h $mins m $secs s] {
  115.         if {$value > 0} {
  116.             append text "$value$unit "
  117.         }
  118.     }
  119.     return [expr {[info exists text] ? "$text$rel" : "NOW"}]
  120. }
  121.  
  122. proc ::util::toGMT {{date ""}} {
  123.     return [clock format [clock scan $date -base [unixtime]] -format "%Y-%m-%d %H:%M:%S" -gmt 1]
  124. }
  125.  
  126. proc ::util::toLocal {{date ""}} {
  127.     return [clock format [clock scan $date -base [unixtime] -gmt 1] -format "%Y-%m-%d %H:%M:%S"]
  128. }
  129.  
  130. proc ::util::now {{gmt 1}} {
  131.     return [expr {$gmt ? [toGMT] : [toLocal]}]
  132. }
  133.  
  134. proc ::util::currentYear {{gmt 1}} {
  135.     return [clock format [unixtime] -format "%Y" -gmt $gmt]
  136. }
  137.  
  138. proc ::util::timezone {{withOffset 0}} {
  139.     return [strftime "%Z[expr {$withOffset ? " %z" : ""}]" [unixtime]]
  140. }
  141.  
  142. proc ::util::validTimeZone {tz} {
  143.     set timezones {
  144.         gmt ut utc bst wet wat at nft nst ndt ast adt est edt cst cdt mst mdt
  145.         pst pdt yst ydt hst hdt cat ahst nt idlw cet cest met mewt mest swt
  146.         sst eet eest bt it zp4 zp5 ist zp6 wast wadt jt cct jst cast cadt
  147.         east eadt gst nzt nzst nzdt idle
  148.     }
  149.     return [expr {[lsearch -exact $timezones $tz] != -1}]
  150. }
  151.  
  152. proc ::util::DST {} {
  153.     set cmp [string compare [clock format [unixtime] -format "%Z"]\
  154.         [clock format [clock scan "6 months" -base [unixtime]] -format "%Z"]]
  155.     return [expr {($cmp < 0) ? 1 : (($cmp > 0) ? 0 : -1)}]
  156. }
  157.  
  158. proc ::util::wordDay {day} {
  159.     if {[regexp {^\d+$} $day]} {
  160.         if {$day < 11 || $day > 13} {
  161.             switch [string index $day end] {
  162.                 1 { return "${day}st" }
  163.                 2 { return "${day}nd" }
  164.                 3 { return "${day}rd" }
  165.             }
  166.         }
  167.         return "${day}th"
  168.     }
  169.     return $day
  170. }
  171.  
  172. proc ::util::shortYear {utime format} {
  173.     if {[clock format [unixtime] -format "%Y"] == [clock format $utime -format "%Y"]} {
  174.         return ""
  175.     }
  176.     return $format
  177. }
  178.  
  179. proc ::util::formatShortDate {datetime} {
  180.     set dt [clock scan $datetime -base [unixtime] -gmt 1]
  181.     return [string trimleft [clock format $dt -format "%m/%d[shortYear $dt "/%y"]"] 0]
  182. }
  183.  
  184. proc ::util::formatDateTime {datetime} {
  185.     set dt [clock scan $datetime -base [unixtime] -gmt 1]
  186.     regsub -all {\s{2,}} [clock format $dt -format "%m/%d[shortYear $dt "/%Y"] %l:%M%P"] " " date
  187.     return [string trimleft $date 0]
  188. }
  189.  
  190. proc ::util::formatWordDate {datetime {formal 1}} {
  191.     set dt [clock scan $datetime -base [unixtime] -gmt 1]
  192.     set date [clock format $dt -format "%b %e[shortYear $dt ", %Y"]"]
  193.     return "[lindex $date 0] [expr {$formal ? [wordDay [lrange $date 1 end]] : [lrange $date 1 end]}]"
  194. }
  195.  
  196. proc ::util::formatWordDateTime {datetime {formal 1}} {
  197.     set dt [clock scan $datetime -base [unixtime] -gmt 1]
  198.     set date [clock format $dt -format "%a, %b %e[shortYear $dt ", %Y"] at %l:%M%P"]
  199.     regsub {:00} $date "" date
  200.     return "[lrange $date 0 1] [expr {$formal ? [wordDay [lindex $date 2]] : [lindex $date 2]}] [lrange $date 3 end]"
  201. }
  202.  
  203. proc ::util::log {loglevel text} {
  204.     if {$loglevel >= 1 && $loglevel <= 8} {
  205.         return [putloglev $loglevel * $text]
  206.     }
  207.     return
  208. }
  209.  
  210. proc ::util::logStackable {unick host handle dest text} {
  211.     if {$unick == $dest} {
  212.         putcmdlog "($unick!$host) !$handle! $text"
  213.     } else {
  214.         putcmdlog "<<$unick>> !$handle! $text"
  215.     }
  216.     return 1
  217. }
  218.  
  219. proc ::util::initCapabilities {from keyword text} {
  220.     variable floodSupport 0
  221.     return 0
  222. }
  223. bind raw - 001 ::util::initCapabilities
  224.  
  225. proc ::util::capabilities {from keyword text} {
  226.     variable floodSupport
  227.     if {[lsearch -exact [split $text] "CPRIVMSG"] >= 0} {
  228.         set floodSupport 1
  229.     }
  230.     return 0
  231. }
  232. bind raw - 005 ::util::capabilities
  233.  
  234. if {[catch {package require eggdrop 1.6.20}]} {
  235.     proc ::putnow {text args} {
  236.         append text "\r\n"
  237.         return [putdccraw 0 [string length $text] $text]
  238.     }
  239. }
  240.  
  241. proc ::util::put {text {queue putquick} {loglevel 0} {prefix ""} {suffix ""} {ellipsis "..."}} {
  242.     global botname
  243.     variable maxMessageLen
  244.     variable maxLineWrap
  245.  
  246.     set maxText [expr $maxMessageLen - [string length $botname]\
  247.         - [string length $prefix] - [string length $suffix] - 2]
  248.  
  249.     set overflow [expr {$maxText < [string length $text]}]
  250.     if {$overflow} {
  251.         incr maxText -[string length $ellipsis]
  252.     }
  253.  
  254.     set lines 0
  255.     set l [string length $text]
  256.     for {set i 0} {$i < $l && $lines < $maxLineWrap} {incr i $maxText} {
  257.         set message [string range $text $i [expr $i + $maxText - 1]]
  258.         if {$overflow} {
  259.             set message [expr {$i ? "$ellipsis$message" : "$message$ellipsis"}]
  260.         }
  261.         log $loglevel "\[>\] $prefix$message$suffix"
  262.         $queue "$prefix$message$suffix"
  263.         incr lines
  264.     }
  265.     if {[string length [string range $text $i end]]} {
  266.         $queue "$prefix\[ Message truncated to $maxLineWrap line[s $maxLineWrap]. \]$suffix"
  267.     }
  268.     return 0
  269. }
  270.  
  271. proc ::util::putType {type unick dest text {queue putquick} {loglevel 0}} {
  272.     global botnick
  273.     variable floodSupport
  274.  
  275.     if {$floodSupport} {
  276.         foreach chan [concat [list $dest] [channels]] {
  277.             if {[validchan $chan] && [isop $botnick $chan] && [onchan $unick $chan]} {
  278.                 return [put $text $queue $loglevel "C$type $unick $chan :"]
  279.             }
  280.         }
  281.     }
  282.     if {[string index $dest 0] != "#" && $queue == "putnow"} {
  283.         set queue putquick
  284.     }
  285.     return [put $text $queue $loglevel "$type $unick :"]
  286. }
  287.  
  288. proc ::util::putMessage {unick dest text {queue putquick} {loglevel 0}} {
  289.     return [putType "PRIVMSG" $unick $dest $text $queue $loglevel]
  290. }
  291.  
  292. proc ::util::putNotice {unick dest text {queue putquick} {loglevel 0}} {
  293.     return [putType "NOTICE" $unick $dest $text $queue $loglevel]
  294. }
  295.  
  296. proc ::util::putAction {unick dest text {queue putquick} {loglevel 0}} {
  297.     return [put $text $queue $loglevel "PRIVMSG $unick :\001ACTION found " "\001"]
  298. }
  299.  
  300. proc ::util::redirect {handler unick host handle text} {
  301.     if {[llength $handler] == 1} {
  302.         return [$handler $unick $host $handle $unick $text]
  303.     }
  304.     return [[lindex $handler 0] [lrange $handler 1 end] $unick $host $handle $unick $text]
  305. }
  306.  
  307. proc ::util::mbind {types flags triggers handler} {
  308.     variable ns
  309.  
  310.     set totalBinds 0
  311.     set msgHandler [list ${ns}::redirect $handler]
  312.  
  313.     foreach type $types {
  314.         set eventHandler $handler
  315.         if {$type == "msg" || $type == "msgm"} {
  316.             set eventHandler $msgHandler
  317.         }
  318.         foreach trigger $triggers {
  319.             if {$type == "msgm" && [llength $trigger] > 1} {
  320.                 set trigger [lrange [split $trigger] 1 end]
  321.             }
  322.             bind $type $flags $trigger $eventHandler
  323.             incr totalBinds
  324.         }
  325.     }
  326.     return $totalBinds
  327. }
  328.  
  329. proc  ::util::c {color {bgcolor ""}} {
  330.     return "\003$color[expr {$bgcolor == "" ? "" : ",$bgcolor"}]"
  331. }
  332. proc ::util::/c {} { return "\003" }
  333. proc  ::util::b {} { return "\002" }
  334. proc ::util::/b {} { return "\002" }
  335. proc  ::util::r {} { return "\026" }
  336. proc ::util::/r {} { return "\026" }
  337. proc  ::util::u {} { return "\037" }
  338. proc ::util::/u {} { return "\037" }
  339.  
  340. # for database maintenance - use with caution!
  341. proc ::util::sql {command db handle idx query} {
  342.     putcmdlog "#$handle# $command $query"
  343.     if {[catch {$db eval $query row {
  344.         set results {}
  345.         foreach field $row(*) {
  346.             lappend results "[b]$field[/b]($row($field))"
  347.         }
  348.         putdcc $idx [join $results]
  349.     }} error]} {
  350.         putdcc $idx "*** SQL query failed: $error"
  351.     }
  352.     return 0
  353. }
  354.  
  355. proc ::util::bindSQL {command db {flags "n"}} {
  356.     variable ns
  357.     return [bind dcc $flags $command [list ${ns}::sql $command $db]]
  358. }
  359.  
  360. proc ::util::backup {db dbFile loglevel minute hour day month year} {
  361.     set backupFile "$dbFile.bak"
  362.     log $loglevel "Backing up $dbFile database to $backupFile..."
  363.     catch {
  364.         $db backup $backupFile
  365.         exec chmod 600 $backupFile
  366.     }
  367.     return
  368. }
  369.  
  370. proc ::util::scheduleBackup {db dbFile {when "04:00"} {loglevel 0}} {
  371.     variable ns
  372.     set when [split $when ":"]
  373.     set hour [lindex $when 0]
  374.     set minute [lindex $when 1]
  375.     return [bind time - "$minute $hour * * *" [list ${ns}::backup $db $dbFile $loglevel]]
  376. }
  377.  
  378. proc ::util::cleanup {nsRef db type} {
  379.     foreach bind [binds "*${nsRef}::*"] {
  380.         foreach {type flags command {} handler} $bind {
  381.             catch {unbind $type $flags $command $handler}
  382.         }
  383.     }
  384.     catch {$db close}
  385.     namespace delete $nsRef
  386.     return
  387. }
  388.  
  389. proc ::util::registerCleanup {nsRef db} {
  390.     variable ns
  391.     return [bind evnt - prerehash [list ${ns}::cleanup $nsRef $db]]
  392. }
  393.  
  394. proc ::util::geturlex {url args} {
  395.     http::config -useragent "Mozilla/4.0 (compatible; MSIE 8.0; Windows NT 6.2; Trident/4.0)"
  396.  
  397.     array set URI [::uri::split $url] ;# Need host info from here
  398.     foreach x {1 2 3 4 5} {
  399.         if {[catch {set token [eval [list http::geturl $url] $args]}]} {
  400.             break
  401.         }
  402.         if {![string match {30[1237]} [::http::ncode $token]]} {
  403.             return $token
  404.         }
  405.         array set meta [set ${token}(meta)]
  406.         if {[set location [lsearch -inline -nocase -exact [array names meta] "location"]] == ""} {
  407.             return $token
  408.         }
  409.         array set uri [::uri::split $meta($location)]
  410.         unset meta
  411.         if {$uri(host) == ""} {
  412.             set uri(host) $URI(host)
  413.         }
  414.         # problem w/ relative versus absolute paths
  415.         set url [eval ::uri::join [array get uri]]
  416.     }
  417.     return -1
  418. }
  419.  
  420. array set ::util::htmlEntityMap {
  421.     quot \x22 amp \x26 lt \x3C gt \x3E nbsp \xA0 iexcl \xA1 cent \xA2 pound \xA3
  422.     curren \xA4 yen \xA5 brvbar \xA6 sect \xA7 uml \xA8 copy \xA9 ordf \xAA
  423.     laquo \xAB not \xAC shy \xAD reg \xAE macr \xAF deg \xB0 plusmn \xB1
  424.     sup2 \xB2 sup3 \xB3 acute \xB4 micro \xB5 para \xB6 middot \xB7 cedil \xB8
  425.     sup1 \xB9 ordm \xBA raquo \xBB frac14 \xBC frac12 \xBD frac34 \xBE
  426.     iquest \xBF Agrave \xC0 Aacute \xC1 Acirc \xC2 Atilde \xC3 Auml \xC4
  427.     Aring \xC5 AElig \xC6 Ccedil \xC7 Egrave \xC8 Eacute \xC9 Ecirc \xCA
  428.     Euml \xCB Igrave \xCC Iacute \xCD Icirc \xCE Iuml \xCF ETH \xD0 Ntilde \xD1
  429.     Ograve \xD2 Oacute \xD3 Ocirc \xD4 Otilde \xD5 Ouml \xD6 times \xD7
  430.     Oslash \xD8 Ugrave \xD9 Uacute \xDA Ucirc \xDB Uuml \xDC Yacute \xDD
  431.     THORN \xDE szlig \xDF agrave \xE0 aacute \xE1 acirc \xE2 atilde \xE3
  432.     auml \xE4 aring \xE5 aelig \xE6 ccedil \xE7 egrave \xE8 eacute \xE9
  433.     ecirc \xEA euml \xEB igrave \xEC iacute \xED icirc \xEE iuml \xEF eth \xF0
  434.     ntilde \xF1 ograve \xF2 oacute \xF3 ocirc \xF4 otilde \xF5 ouml \xF6
  435.     divide \xF7 oslash \xF8 ugrave \xF9 uacute \xFA ucirc \xFB uuml \xFC
  436.     yacute \xFD thorn \xFE yuml \xFF
  437.     ob \x7b cb \x7d bsl \\
  438.     #8203 "" #x200b "" ndash - #8211 - #x2013 - mdash -- #8212 -- #x2014 --
  439.     circ ^ #710 ^ #x2c6 ^ tilde ~ #732 ~ #x2dc ~
  440.     lsquo ' #8216 ' #x2018 ' rsquo ' #8217 ' #x2019 ' sbquo ' #8218 ' #x201a '
  441.     ldquo \" #8220 \" #x201c \" rdquo \" #8221 \" #x201d \" bdquo \" #8222 \" #x201e \"
  442.     dagger | #8224 | #x2020 | Dagger | #8225 | #x2021 |
  443.     lsaquo < #8249 < #x2039 < rsaquo > #8250 > #x203a >
  444. }
  445.  
  446. proc ::util::getHTMLEntity {text {unknown ?}} {
  447.     variable htmlEntityMap
  448.     set result $unknown
  449.     catch {set result $htmlEntityMap($text)}
  450.     return $result
  451. }
  452.  
  453. proc ::util::htmlDecode {text} {
  454.     if {![regexp & $text]} {
  455.         return $text
  456.     }
  457.     regsub -all {([][$\\])} $text {\\\1} new
  458.     regsub -all {&(#[xX]?[\da-fA-F]{1,4});} $new {[getHTMLEntity [string tolower \1] "\x26\1;"]} new
  459.     regsub -all {([][$\\])} [subst $new] {\\\1} new
  460.     regsub -all {&#(\d{1,4});} $new {[format %c [scan \1 %d tmp;set tmp]]} new
  461.     regsub -all {&#[xX]([\da-fA-F]{1,4});} $new {[format %c [scan [expr "0x\1"] %d tmp;set tmp]]} new
  462.     regsub -all {&([a-zA-Z]+);} $new {[getHTMLEntity \1]} new
  463.     return [subst $new]
  464. }
  465.  
  466. proc ::util::parseHTML {html {cmd testParser} {start hmstart}} {
  467.     regsub -all \{ $html {\&ob;} html
  468.     regsub -all \} $html {\&cb;} html
  469.     regsub -all {\\} $html {\&bsl;} html
  470.     set w " \t\r\n"  ;# white space
  471.     set exp <(/?)(\[^$w>]+)\[$w]*(\[^>]*)>
  472.     set sub "\}\n$cmd {\\2} {\\1} {\\3} \{"
  473.     regsub -all $exp $html $sub html
  474.     eval "$cmd {$start} {} {} {$html}"
  475.     eval "$cmd {$start} / {} {}"
  476. }
  477.  
  478. proc ::util::testParser {tag state props body} {
  479.     if {$state == ""} {
  480.         set msg "Start $tag"
  481.         if {$props != ""} {
  482.             set msg "$msg with args: $props"
  483.         }
  484.         set msg "$msg\n$body"
  485.     } else {
  486.         set msg "End $tag"
  487.     }
  488.     putlog $msg
  489. }
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement
Public Pastes
Advertisement
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!