API tools faq
paste
Advertisement
Guest User

Untitled

a guest
Jul 18th, 2017
52
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
TCL 16.04 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: January 28, 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 maxLines      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 maxLines
  245.  
  246.     set textLimit [expr $maxMessageLen - [string length $botname]\
  247.         - [string length $prefix] - [string length $suffix] - 2]
  248.  
  249.     if {[expr {$textLimit < [string length $text]}]} {
  250.         set limit [expr $textLimit - [string length $ellipsis] - 1]
  251.         set re [expr {$limit > 255 ? ".{1,255}.{1,[expr $limit - 255]}" : ".{1,$limit}"}]
  252. #       putlog "($re\\S)\\s+"
  253.         set g [regsub -all "($re\\S)\\s+(?=\\S)" [string trimright $text] "\\1$ellipsis\n" text]
  254. #       putlog "$g TEXT($text)"
  255.     }
  256.  
  257.     set lines 0
  258.     foreach line [split $text \n] {
  259.         putlog "$lines. ($line)"
  260.         if {[incr lines] > $maxLines} {
  261.             $queue "$prefix\[ Message truncated to $maxLines line[s $maxLines]. \]$suffix"
  262.             break
  263.         }
  264.         log $loglevel "\[>\] $prefix$line$suffix"
  265.         $queue "$prefix$line$suffix"
  266.     }
  267.     return 0
  268.  
  269.     set s $text
  270.     set strLen [string length $s]
  271.     set lineEnd 0
  272.     set nextLineBegin 0
  273.     for {set lineBegin 0} {1} {set lineBegin $nextLineBegin} {
  274.         while {$lineBegin < $strLen && [string index $s $lineBegin] == " "} {
  275.             incr lineBegin
  276.         }
  277.         if {$lineBegin >= $strLen} {
  278.             break
  279.         }
  280.         set nextLineBegin [expr $lineBegin + $textLimit]
  281.         if {$nextLineBegin < $strLen} {
  282.             if {$nextLineBegin <= $lineBegin} {
  283.                 set nextLineBegin [expr $lineBegin + 1]
  284.             } elseif {$textLimit > [string length $ellipsis]} {
  285.                 incr nextLineBegin -[string length $ellipsis]
  286.             }
  287.         } else {
  288.             set nextLineBegin $strLen
  289.         }
  290.         set lineEnd $nextLineBegin
  291.         while {$lineEnd >= $lineBegin} {
  292.             if {[string index $s $lineEnd] == " "} {
  293.                 set nextLineBegin [expr $lineEnd + 1]
  294.                 while {$nextLineBegin < $strLen && [string index $s $nextLineBegin] == " "} {
  295.                     incr nextLineBegin
  296.                 }
  297.                 incr lineEnd -1
  298.                 while {$lineEnd >= $lineBegin && [string index $s $lineEnd] == " "} {
  299.                     incr lineEnd -1
  300.                 }
  301.                 break
  302.             }
  303.             incr lineEnd -1
  304.         }
  305.         if {$lineEnd < $lineBegin} {
  306.             set lineEnd [expr $nextLineBegin - 1]
  307.         }
  308.         set str [string range $s $lineBegin [expr $lineEnd + 1]]
  309.         if {$nextLineBegin < $strLen && $textLimit > [string length $ellipsis]} {
  310.             append str $ellipsis
  311.         }
  312.         log $loglevel "\[>\] $prefix$str$suffix"
  313.         $queue "$prefix$str$suffix"
  314.     }
  315.  
  316.     return 0
  317. }
  318.  
  319. proc ::util::putType {type unick dest text {queue putquick} {loglevel 0}} {
  320.     global botnick
  321.     variable floodSupport
  322.  
  323.     if {$floodSupport} {
  324.         foreach chan [concat [list $dest] [channels]] {
  325.             if {[validchan $chan] && [isop $botnick $chan] && [onchan $unick $chan]} {
  326.                 return [put $text $queue $loglevel "C$type $unick $chan :"]
  327.             }
  328.         }
  329.     }
  330.     if {[string index $dest 0] != "#" && $queue == "putnow"} {
  331.         set queue putquick
  332.     }
  333.     return [put $text $queue $loglevel "$type $unick :"]
  334. }
  335.  
  336. proc ::util::putMessage {unick dest text {queue putquick} {loglevel 0}} {
  337.     return [putType "PRIVMSG" $unick $dest $text $queue $loglevel]
  338. }
  339.  
  340. proc ::util::putNotice {unick dest text {queue putquick} {loglevel 0}} {
  341.     return [putType "NOTICE" $unick $dest $text $queue $loglevel]
  342. }
  343.  
  344. proc ::util::putAction {unick dest text {queue putquick} {loglevel 0}} {
  345.     return [put $text $queue $loglevel "PRIVMSG $unick :\001ACTION found " "\001"]
  346. }
  347.  
  348. proc ::util::redirect {handler unick host handle text} {
  349.     if {[llength $handler] == 1} {
  350.         return [$handler $unick $host $handle $unick $text]
  351.     }
  352.     return [[lindex $handler 0] [lrange $handler 1 end] $unick $host $handle $unick $text]
  353. }
  354.  
  355. proc ::util::mbind {types flags triggers handler} {
  356.     variable ns
  357.  
  358.     set totalBinds 0
  359.     set msgHandler [list ${ns}::redirect $handler]
  360.  
  361.     foreach type $types {
  362.         set eventHandler $handler
  363.         if {$type == "msg" || $type == "msgm"} {
  364.             set eventHandler $msgHandler
  365.         }
  366.         foreach trigger $triggers {
  367.             if {$type == "msgm" && [llength $trigger] > 1} {
  368.                 set trigger [lrange [split $trigger] 1 end]
  369.             }
  370.             bind $type $flags $trigger $eventHandler
  371.             incr totalBinds
  372.         }
  373.     }
  374.     return $totalBinds
  375. }
  376.  
  377. proc  ::util::c {color {bgcolor ""}} {
  378.     return "\003$color[expr {$bgcolor == "" ? "" : ",$bgcolor"}]"
  379. }
  380. proc ::util::/c {} { return "\003" }
  381. proc  ::util::b {} { return "\002" }
  382. proc ::util::/b {} { return "\002" }
  383. proc  ::util::r {} { return "\026" }
  384. proc ::util::/r {} { return "\026" }
  385. proc  ::util::u {} { return "\037" }
  386. proc ::util::/u {} { return "\037" }
  387.  
  388. # for database maintenance - use with caution!
  389. proc ::util::sql {command db handle idx query} {
  390.     putcmdlog "#$handle# $command $query"
  391.     if {[catch {$db eval $query row {
  392.         set results {}
  393.         foreach field $row(*) {
  394.             lappend results "[b]$field[/b]($row($field))"
  395.         }
  396.         putdcc $idx [join $results]
  397.     }} error]} {
  398.         putdcc $idx "*** SQL query failed: $error"
  399.     }
  400.     return 0
  401. }
  402.  
  403. proc ::util::bindSQL {command db {flags "n"}} {
  404.     variable ns
  405.     return [bind dcc $flags $command [list ${ns}::sql $command $db]]
  406. }
  407.  
  408. proc ::util::backup {db dbFile loglevel minute hour day month year} {
  409.     set backupFile "$dbFile.bak"
  410.     log $loglevel "Backing up $dbFile database to $backupFile..."
  411.     catch {
  412.         $db backup $backupFile
  413.         exec chmod 600 $backupFile
  414.     }
  415.     return
  416. }
  417.  
  418. proc ::util::scheduleBackup {db dbFile {when "04:00"} {loglevel 0}} {
  419.     variable ns
  420.     set when [split $when ":"]
  421.     set hour [lindex $when 0]
  422.     set minute [lindex $when 1]
  423.     return [bind time - "$minute $hour * * *" [list ${ns}::backup $db $dbFile $loglevel]]
  424. }
  425.  
  426. proc ::util::cleanup {nsRef db type} {
  427.     foreach bind [binds "*${nsRef}::*"] {
  428.         foreach {type flags command {} handler} $bind {
  429.             catch {unbind $type $flags $command $handler}
  430.         }
  431.     }
  432.     catch {$db close}
  433.     namespace delete $nsRef
  434.     return
  435. }
  436.  
  437. proc ::util::registerCleanup {nsRef db} {
  438.     variable ns
  439.     return [bind evnt - prerehash [list ${ns}::cleanup $nsRef $db]]
  440. }
  441.  
  442. proc ::util::geturlex {url args} {
  443.     http::config -useragent "Mozilla/4.0 (compatible; MSIE 8.0; Windows NT 6.2; Trident/4.0)"
  444. #   http::config -proxyhost localhost
  445. #   http::config -proxyport 8888
  446.  
  447.     array set URI [::uri::split $url] ;# Need host info from here
  448.     foreach x {1 2 3 4 5} {
  449.         if {[catch {set token [eval [list http::geturl $url] $args]}]} {
  450.             break
  451.         }
  452.         if {![string match {30[1237]} [::http::ncode $token]]} {
  453.             return $token
  454.         }
  455.         array set meta [set ${token}(meta)]
  456.         if {![info exist meta(Location)]} {
  457.             return $token
  458.         }
  459.         array set uri [::uri::split $meta(Location)]
  460.         unset meta
  461.         if {$uri(host) == ""} {
  462.             set uri(host) $URI(host)
  463.         }
  464.         # problem w/ relative versus absolute paths
  465.         set url [eval ::uri::join [array get uri]]
  466.     }
  467.     return -1
  468. }
  469.  
  470. array set ::util::htmlEntityMap {
  471.     quot \x22 amp \x26 lt \x3C gt \x3E nbsp \xA0 iexcl \xA1 cent \xA2 pound \xA3
  472.     curren \xA4 yen \xA5 brvbar \xA6 sect \xA7 uml \xA8 copy \xA9 ordf \xAA
  473.     laquo \xAB not \xAC shy \xAD reg \xAE macr \xAF deg \xB0 plusmn \xB1
  474.     sup2 \xB2 sup3 \xB3 acute \xB4 micro \xB5 para \xB6 middot \xB7 cedil \xB8
  475.     sup1 \xB9 ordm \xBA raquo \xBB frac14 \xBC frac12 \xBD frac34 \xBE
  476.     iquest \xBF Agrave \xC0 Aacute \xC1 Acirc \xC2 Atilde \xC3 Auml \xC4
  477.     Aring \xC5 AElig \xC6 Ccedil \xC7 Egrave \xC8 Eacute \xC9 Ecirc \xCA
  478.     Euml \xCB Igrave \xCC Iacute \xCD Icirc \xCE Iuml \xCF ETH \xD0 Ntilde \xD1
  479.     Ograve \xD2 Oacute \xD3 Ocirc \xD4 Otilde \xD5 Ouml \xD6 times \xD7
  480.     Oslash \xD8 Ugrave \xD9 Uacute \xDA Ucirc \xDB Uuml \xDC Yacute \xDD
  481.     THORN \xDE szlig \xDF agrave \xE0 aacute \xE1 acirc \xE2 atilde \xE3
  482.     auml \xE4 aring \xE5 aelig \xE6 ccedil \xE7 egrave \xE8 eacute \xE9
  483.     ecirc \xEA euml \xEB igrave \xEC iacute \xED icirc \xEE iuml \xEF eth \xF0
  484.     ntilde \xF1 ograve \xF2 oacute \xF3 ocirc \xF4 otilde \xF5 ouml \xF6
  485.     divide \xF7 oslash \xF8 ugrave \xF9 uacute \xFA ucirc \xFB uuml \xFC
  486.     yacute \xFD thorn \xFE yuml \xFF
  487.     ob \x7b cb \x7d bsl \\
  488.     #8203 "" #x200b "" ndash - #8211 - #x2013 - mdash -- #8212 -- #x2014 --
  489.     circ ^ #710 ^ #x2c6 ^ tilde ~ #732 ~ #x2dc ~
  490.     lsquo ' #8216 ' #x2018 ' rsquo ' #8217 ' #x2019 ' sbquo ' #8218 ' #x201a '
  491.     ldquo \" #8220 \" #x201c \" rdquo \" #8221 \" #x201d \" bdquo \" #8222 \" #x201e \"
  492.     dagger | #8224 | #x2020 | Dagger | #8225 | #x2021 |
  493.     lsaquo < #8249 < #x2039 < rsaquo > #8250 > #x203a >
  494. }
  495.  
  496. proc ::util::getHTMLEntity {text {unknown ?}} {
  497.     variable htmlEntityMap
  498.     set result $unknown
  499.     catch {set result $htmlEntityMap($text)}
  500.     return $result
  501. }
  502.  
  503. proc ::util::htmlDecode {text} {
  504.     if {![regexp & $text]} {
  505.         return $text
  506.     }
  507.     regsub -all {([][$\\])} $text {\\\1} new
  508.     regsub -all {&(#[xX]?[\da-fA-F]{1,4});} $new {[getHTMLEntity [string tolower \1] "\x26\1;"]} new
  509.     regsub -all {([][$\\])} [subst $new] {\\\1} new
  510.     regsub -all {&#(\d{1,4});} $new {[format %c [scan \1 %d tmp;set tmp]]} new
  511.     regsub -all {&#[xX]([\da-fA-F]{1,4});} $new {[format %c [scan [expr "0x\1"] %d tmp;set tmp]]} new
  512.     regsub -all {&([a-zA-Z]+);} $new {[getHTMLEntity \1]} new
  513.     return [subst $new]
  514. }
  515.  
  516. proc ::util::parseHTML {html {cmd testParser} {start hmstart}} {
  517.     regsub -all \{ $html {\&ob;} html
  518.     regsub -all \} $html {\&cb;} html
  519.     regsub -all {\\} $html {\&bsl;} html
  520.     set w " \t\r\n"  ;# white space
  521.     set exp <(/?)(\[^$w>]+)\[$w]*(\[^>]*)>
  522.     set sub "\}\n$cmd {\\2} {\\1} {\\3} \{"
  523.     regsub -all $exp $html $sub html
  524.     eval "$cmd {$start} {} {} {$html}"
  525.     eval "$cmd {$start} / {} {}"
  526. }
  527.  
  528. proc ::util::testParser {tag state props body} {
  529.     if {$state == ""} {
  530.         set msg "Start $tag"
  531.         if {$props != ""} {
  532.             set msg "$msg with args: $props"
  533.         }
  534.         set msg "$msg\n$body"
  535.     } else {
  536.         set msg "End $tag"
  537.     }
  538.     putlog $msg
  539. }
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!