Brian's Blog

#### calc.tcl v1.0.1 ###########################################################
################################################################################
## Written by:                                                                ##
##   KuNgFo0  (http://www.eggfaq.com/).              ##
##                                                                            ##
## Modified by:                                                               ##
##   Brian Schmidt aka. brianMan.                                             ##
################################################################################

#### Readme / Help #############################################################
################################################################################
## This script is ripped from KuNgFoO's ib.tcl v3.19 (infobot) script.        ##
##                                                                            ##
## Script that can calculate just about anything ;)                           ##
##                                                                            ##
## Usage:                                                                     ##
##   To have the .calc[ulate] commands available on a channel you need to set ##
##   the channel flag +calculator from the console/partyline .                ##
##   ``.chanset #channel +calculator´´                                        ##
##                                                                            ##
## Channel Commands (available only if channel is +convert):                  ##
##   .calc[ulate]                                                 ##
## Example:                                                                   ##
##   ``.calc 15*20+3´´                                                        ##
################################################################################

#### Changelog #################################################################
################################################################################
## v1.0.1                                                                     ##
## * Minor code cleanup                                                       ##
##                                                                            ##
## v1.0.0                                                                     ##
## + Initial release.                                                         ##
## * Changed the default trigger ``botname, calc[ulate]´´ to ``.calc[ulate]´´ ##
## + Added the possibility to control which channels could use the commands   ##
##   with the channel flag ``+/-calculator´´                                  ##
################################################################################

bind pub - .calc pub_calc
bind pub - .calculate pub_calc
bind msg - calc msg_calc
bind msg - calculate msg_calc

setudef flag calculator

# You shouldn't change these, however you may add additional variables
# These are used via %varname in the 'calculate' command
# Example: Mybot, calculate %pi / 2
set calc_const(pi) 3.14159265358979323846 ; # PI
set calc_const(e)  2.7182818284590452354  ; # E
set calc_const(n)  6.0221367e23           ; # Avogadro's number [1/mol]
set calc_const(R)  8.314510               ; # Universal gas constant [J/(mol*K)]
set calc_const(k)  1.380658e-23           ; # Boltzmann's constant [J/K]
set calc_const(G)  6.67259e-11            ; # Universal gravitational constant [N*m^2/kg^2]
set calc_const(h)  6.62606891e-34         ; # Planck's constant [J*s]
set calc_const(c)  2.99792458e8           ; # Speed of light [m/s]

# No more editing required

proc xrange {xr xr1 xr2} {
    return [join [lrange [split $xr] $xr1 $xr2]]
}

proc xindex {xr xr1} {
    return [join [lrange [split $xr] $xr1 $xr1]]
}

proc calc_fixdata {arg output} {
    global botnick
    if {[string index $output 0] != "#"} {
        regsub -all -nocase {$output's} $arg "your" arg
    }
    regsub -all -nocase {$botnick's} $arg "my" arg
    return $arg
}

proc calc_msg {targets arg} {
    foreach target $targets { puthelp "PRIVMSG $target :[calc_fixdata $arg $target]" }
}

proc calc_fixtopic {arg} {
    regsub -all {[\\\{\}\[\]\"]} $arg {}   arg ; # Bad characters
    regsub -all {(\s)+}          $arg {\1} arg ; # Double whitespace
    regsub -all {^\s*|\s*$}      $arg {}   arg ; # Whitespace at ends
    return $arg
}

# Begin 'calc' code
proc calc_fixexpr {exp} {
    global calc_const
    set exp [calc_fixtopic $exp]
    foreach i [array names calc_const] {
        regsub -all "\%$i" $exp $calc_const($i) exp
    }
    return $exp
}
# End 'calc' code

# Begin Public binds code
proc msg_calc {nick uhost hand arg} {
    global botnick
    pub_calc $nick $uhost $hand "" $arg
}

proc pub_calc {nick uhost hand chan arg} {
    global botnick calc_flag
    if {(![isbotnick $nick]) && (![matchattr $hand +b])} {
        if {(![string match "$chan" ""]) && (![channel get $chan calculator])} {
            return 0 ; # If command comes from a channel, and that channel doesn't have +calculator then ignore
        }
        set isuser [expr {[matchattr $hand - $chan] || [matchattr $hand -]}] ; # Note that $chan might be "", so we must handle both cases
        if {([validchan $chan]) && ($isuser)} {
            set output1 $chan ; # The bot sends the text to the channel for users
        } else {
            set output1 $nick ; # Non-users get privmsg'd
        }
        if {[set i [string last ">" $arg]] == -1} {
            set output2 $output1 ; # By default, output2 (~stdout~) goes to output1 (~stderr~)
        } else {
            # Output has been redirected
            if {(!$isuser) || ([set output2 [string trim [string range $arg [expr $i + 1] end] " "]] == "")} {
                set output2 $output1 ; # Error (User doesn't have access, or output was ""), so we go back to the default
            }
            set arg [string trim [string range $arg 0 [expr $i - 1]] " "]
        }
        set remainder [xrange $arg 0 end]

        if {$remainder == ""} {
            calc_msg $output1 "error parsing sentence"
        } elseif {[catch {expr [calc_fixexpr $remainder]} output]} {
            calc_msg $output1 "error calculating '$remainder' ($output)"
        } else {
            calc_msg $output2 "$remainder = $output"
        }
    }
}
# End Public binds code

# Init stuff
if {[catch {package require Tcl 8.2} error]} {
    putlog "error TCL v8.2 or higher is required to run this script"
    return 0
}

putlog "*** LOADED: calc.tcl"

#### convert.tcl v1.0.1 ########################################################
################################################################################
## Written by:                                                                ##
##   KuNgFo0  (http://www.eggfaq.com/).              ##
##                                                                            ##
## Modified by:                                                               ##
##   Brian Schmidt aka. brianMan.                                             ##
################################################################################

#### Readme / Help #############################################################
################################################################################
## This script is ripped from KuNgFoO's ib.tcl v3.19 (infobot) script.        ##
##                                                                            ##
## The script converts between a number of various units, for more speficic   ##
## information on which untis you should please refer to the source of this   ##
## script.                                                                    ##
##                                                                            ##
## Usage:                                                                     ##
##   To have the .conv[ert] commands available on a channel you need to set   ##
##   the channel flag +convert from the console/partyline .                   ##
##   ``.chanset #channel +convert´´                                           ##
##                                                                            ##
## Channel Commands (available only if channel is +convert):                  ##
##   .conv[ert]   to                               ##
## Example:                                                                   ##
##   ``.conv 20 C to F´´                                                      ##
##   Converts 20 degrees Celcius to it's Fahrenheit equivilant.               ##
################################################################################

#### Changelog #################################################################
################################################################################
## v1.0.1                                                                     ##
## * Minor code cleanup                                                       ##
##                                                                            ##
## v1.0.0                                                                     ##
## + Initial release.                                                         ##
## * Changed the default trigger ``botname, conv[ert]´´ to ``.con[vert]´´     ##
## + Added the possibility to control which channels could use the commands   ##
##   with the channel flag ``+/-convert´´                                     ##
################################################################################

bind pub - .conv pub_conv
bind pub - .convert pub_conv
bind msg - conv msg_conv
bind msg - convert msg_conv

# Set the name of the channelflag used to tell whether the convert command is
# enabled or not for that specific channel.
set conv_channel_flag "convert"

setudef flag $conv_channel_flag

# Set the next line as the exec command to run the 'units' command from the shell
# Note: Not all systems will have this installed
# Set to "" to disable
set conv_units_exec "units -v"

# Conversion formulas - each array is for its own dimension (length, volume, etc).
# Each unit is converted to a standard type by multiplying the value by the factors
# below.  It is then converted from the standard type to any other unit by
# dividing the factors.  The standard unit used must be the same for everything in
# each dimension, and can be anything as long as they are the same.  I used the root
# metric units for most things (meters, liters, grams, etc).
# Note: All strings are matched as regular expressions
# * Prefix with (?c) for units that should be case sensitive
# * Prefix with (.*?) for metric units
# * Append (?:s) for units with an optional plural ending, etc
# * Only use multiplication and division in the formulas, no addition or subtraction
# * It's a very good idea to have all the formulas return values in decimal form
#   ("1" doesn't matter, though)
# Syntax:
#  name abbreviation factor
set conv_unit(length) {
    (.*?)meter(?:s)? (.*?)m 1
    inch(?:es)?      in     {2.54 / 100}
    foot|feet        ft     {2.54 / 100 * 12}
    mile(?:s)?       mi     {2.54 / 100 * 12 * 5280}
}
set conv_unit(volume) {
    (.*?)liter(?:s)? (.*?)L 1
    pint(?:s)?       pt     {3.785 / 8}
    quart(?:s)?      qt     {3.785 / 4}
    gallon(?:s)?     gal    3.785
}
set conv_unit(weight) {
    (.*?)gram(?:s)? (.*?)g 1
    ounce(?:s)?     oz     28.35
    pound(?:s)?     lbs    453.59
    ton(?:s)?       T      {453.59 * 2000}
}
set conv_unit(work) {
    (.*?)joule(?:s)?         (.*?)J      1
    (.*?)watt-?second(?:s)?  (.*?)w-?s   1
    (.*?)watt-?hour(?:s)?    (.*?)w-?hrs 3600.0
    britishthermalunit(?:s)? btu         1055.056
    calorie(?:s)?            cal         4.1868
    foot-?pound(?:s)?        ft-?lbs     1.356
    electron-?volt(?:s)?     eV          1.6021917E-19
}
set conv_unit(power) {
    (.*?)watt(?:s)? (.*?)w 1
    volt-?amp(?:s)? va     1
    horsepower      hp     746
}
set conv_unit(time) {
    (.*?)second(?:s)? (.*?)s(?:ec(?:s)?)? 1
    minute(?:s)?      min(?:s)?           60.0
    hour(?:s)?        h(?:r(?:s)?)?       {60.0 * 60}
    day(?:s)?         {}                  {60.0 * 60 * 24}
    week(?:s)?        wk(?:s)?            {60.0 * 60 * 24 * 7}
    year(?:s)?        yr(?:s)?            {60.0 * 60 * 24 * 365}
    decade(?:s)?      {}                  {60.0 * 60 * 24 * 365 * 10}
    century|centuries {}                  {60.0 * 60 * 24 * 365 * 100}
}
set conv_unit(binary) {
    option metric 2
    (.*?)byte(?:s)? (.*?)b 1
    (.*?)bit(?:s)?  {}     {1.0 / 8}
}

# Misc conversion formulas - these are types that cannot
# be converted by regular multiplication/division of factors.
# The principle is the same as the formulas above, however
# the arrays are broken down into *_from and *_to variables.
# Note: $value is used as the value being converted.
set conv_misc_from(num) {
    option metric 0
    integer|int              {} {[scan $value "%d"]}
    long                     {} {[scan $value "%u"]}
    decimal|dec|float|double {} {[scan $value "%f"]}
    octal|oct                {} {[scan $value "%o"]}
    hexadecimal|hex          {} {[scan $value "%x"]}
    binary|bin               {} {[bin2int $value]}
    ip                       {} {[ip2long $value]}
    rgb                      {} {[rgb2int $value]}
}
set conv_misc_to(num) {
    option metric 0
    integer|int              {} {[format "%d" [conv_int $value]]}
    long                     {} {[format "%u" [conv_int $value]]}
    decimal|dec|float|double {} {[format "%f" $value]}
    octal|oct                {} {[format "%o" [conv_int $value]]}
    hexadecimal|hex          {} {[format "%X" [conv_int $value]]}
    binary|bin               {} {[int2bin [conv_int $value]]}
    ip                       {} {[long2ip [conv_int $value]]}
    rgb                      {} {[int2rgb [conv_int $value]]}
}
set conv_misc_from(temperature) {
    option metric 0
    fahrenheit         F {($value - 32) * 5 / 9.0}
    kelvin             K {$value - 273.15}
    celsius|centigrade C {$value}
}
set conv_misc_to(temperature) {
    option metric 0
    fahrenheit         F {(9 / 5.0 * $value) + 32}
    kelvin             K {$value + 273.15}
    celsius|centigrade C {$value}
}

# Conversion strings to specificially ignore (that conflict with expr)
set conv_ignore {
    e abs acos asin
    atan atan2 ceil
    cos cosh double
    exp floor fmod
    hypot int log
    log10 pow rand
    round sin sinh
    sqrt srand tan
    tanh
}

# Metric conversion factors
# Note: Abbreviations are case sensitive here
# Syntax:
#  mame abbreviation factor
set conv_metric {
    Yotta Y  24
    Zetta Z  21
    Exa   E  18
    Peta  P  15
    Tera  T  12
    Giga  G  9
    Mega  M  6
    Kilo  k  3
    Hecto h  2
    Deca  dk 1

    Deci  d  -1
    Centi c  -2
    Milli m  -3
    Micro µ  -6
    Nano  n  -9
    Pico  p  -12
    Femto f  -15
    Atto  a  -18
    Zepto z  -21
    Yocto y  -24
}

proc xrange {xr xr1 xr2} {
    return [join [lrange [split $xr] $xr1 $xr2]]
}

proc anymatch {string1 string2} {
    foreach string $string2 {
        if {[lsearch -exact [string tolower $string1] [string tolower $string]] != -1} {
            return 1
        }
    }
    return 0
}

proc conv_fixtopic {arg} {
    regsub -all {[\\\{\}\[\]\"]} $arg {}   arg ; # Bad characters
    regsub -all {(\s)+}          $arg {\1} arg ; # Double whitespace
    regsub -all {^\s*|\s*$}      $arg {}   arg ; # Whitespace at ends
    return $arg
}

proc conv_fixdata {arg output} {
    global botnick
    if {[string index $output 0] != "#"} {
        regsub -all -nocase {$output's} $arg "your" arg
    }
    regsub -all -nocase {$botnick's} $arg "my" arg
    return $arg
}

proc conv_msg {targets arg} {
    foreach target $targets {
        puthelp "PRIVMSG $target :[conv_fixdata $arg $target]"
    }
}

proc conv_fixexpr {exp} {
    global ib_const
    set exp [conv_fixtopic $exp]
    foreach i [array names ib_const] {
        regsub -all "\%$i" $exp $ib_const($i) exp
    }
    return $exp
}

# Begin conversion code
proc int2bin {int} {
    return [format "%s.%s.%s.%s" \
    [byte2bin [expr ($int >> 24) & 0xff]] \
    [byte2bin [expr ($int >> 16) & 0xff]] \
    [byte2bin [expr ($int >> 8)  & 0xff]] \
    [byte2bin [expr $int         & 0xff]]]
}

proc byte2bin {byte} {
    set result ""
    for {set i 0} {$i < 8} {incr i} {
        append result [expr ($byte & 128) >> 7]
        set byte [expr $byte << 1]
    }
    return $result
}

proc bin2int {bin} {
    set result 0
    for {set i 0} {$i < [string length $bin]} {incr i} {
        if {([set digit [string index $bin $i]] == 0) || ($digit == 1)} {
            set result [expr $result << 1 | $digit]
        } elseif {$digit == "."} {
            #ignore
        } else {
            set result ""
        }
    }
    return $result
}

proc ip2long {ip} {
    if {[scan $ip "%d.%d.%d.%d" a b c d] == 4} {
        foreach i "$a $b $c $d" {
            if {($i > 255) || ($i < 0)} {
                return ""
            }
        }
        set long [expr $a << 24 | $b << 16 | $c << 8 | $d]
        if {$long < 0} {
            set long [expr pow(2, 32) + $long]
        }
        return $long
    } else {
        return ""
    }
}

proc long2ip {long} {
    return [format "%d.%d.%d.%d" \
    [expr ($long >> 24) & 0xff] \
    [expr ($long >> 16) & 0xff] \
    [expr ($long >> 8)  & 0xff] \
    [expr $long         & 0xff]]
}

proc rgb2int {rgb} {
    if {[scan $rgb "%d.%d.%d" red green blue] == 3} { return [expr $red << 16 | $green << 8 | $blue << 0] } \
    else { return "" }
}

proc int2rgb {long} {
    return [format "%d.%d.%d" \
    [expr ($long >> 16) & 0xff] \
    [expr ($long >> 8)  & 0xff] \
    [expr $long         & 0xff]]
}

# expr's abs() and int() can't handle large unsigned integers,
# these functions are just to get around this
proc conv_int {value} {
    return [lindex [split $value "."] 0]
}

proc conv_abs {value} {
    return [string trimleft $value "-"]
}

proc conv_absint {value} {
    return [conv_int [conv_abs $value]]
}

proc conv_units {value type1 type2} {
    global conv_units_exec
    regsub -all {'} [conv_fixtopic $type1] {} type1
    regsub -all {'} [conv_fixtopic $type2] {} type2
    if {[catch {exec bash -c "$conv_units_exec '$value $type1' '$type2'"} output]} {
        error $output
    }
    foreach line [split $output \n] {
        if {[regexp -- {^\s*([^=]+=.+)$} $line tmp result]} {
            return $result
        }
    }
    error "unknown response from units command"
}

proc conv_scan {var_formula var_unit index} {
    global conv_ignore conv_unit
    upvar 1 $var_formula formula $var_unit unit
    set string {([a-z]+(-[a-z]+)?)}
    if {[regexp -nocase -start $index -- $string $formula a unit]} {
        if {[lsearch -exact $conv_ignore $unit] != -1} {
            # Ignore this unit and search for the next unit
            regexp -nocase -start $index -indices $string -- $formula a index
            return [conv_scan "formula" "unit" [expr [lindex $index 1] + 1]]
        } else {
            # Found unit, return ok
            return 1
        }
    }
    # No more units found
    return 0
}

# $var will be either unit, misc_from, or misc_to
proc conv {value unit var lists} {
    global conv_$var
    upvar 1 list uplist
    if {![info exists uplist]} {
        set uplist ""
    }
    set type [expr {($var == "unit") || ($var == "misc_from") ? "*" : "/"}]
    # First we check full names, then abbreviations
    foreach method {name abbv} {
        foreach list $lists {
            # Default options
            set option_absint 0
            set option_metric 1
            foreach {name abbv formula} [set conv_$var\($list)] {
                if {$name == "option"} {
                    set option_$abbv $formula
                } elseif {[regexp -nocase -- "^([set $method])\$" $unit a b prefix]} {
                    set uplist $list
                    if {([catch {expr $formula} value]) || ($value == "")} {
                        error "evaluating expression for '$unit'"
                    }
                    if {$option_absint} {
                        set value [conv_absint $value]
                    }
                    if {($option_metric) && ($prefix != "") && ([catch {expr [conv_metric $prefix $method $option_metric] $type $value} value])} {
                        error "evaluating metric conversion for '$unit'"
                    }
                    return $value
                }
            }
        }
    }
    error "unknown conversion type '$unit'"
}

# $method will be either "name" or "abbv"
# $option will be either 1 or 2
proc conv_metric {prefix method option} {
    global conv_metric
    foreach {name abbv factor} $conv_metric {
        if {(($method == "name") && ([string equal -nocase $name $prefix])) || (($method == "abbv") && ([string equal $abbv $prefix]))} {
            if {$option == 1} {
                return [expr pow(10, $factor)] ; # Regular metric
            } elseif {$option == 2} {
                return [expr pow(2, ($factor / 3 * 10))] ; # Binary conversion
            }
        }
    }
    error "unknown metric prefix"
}
# End conversion code

# Begin Public binds code
proc msg_conv {nick uhost hand arg} {
    global botnick
    pub_conv $nick $uhost $hand "" $arg
}

proc pub_conv {nick uhost hand chan arg} {
    global botnick value global conv_channel_flag
    global conv_units_exec conv_unit conv_misc_from conv_misc_to
    if {(![isbotnick $nick]) && (![matchattr $hand +b])} {
        if {(![string match "$chan" ""]) && (![channel get $chan $conv_channel_flag])} {
            return 0 ; # If command comes from a channel, and that channel doesn't have +convert then ignore
        }
        set isuser [expr {[matchattr $hand - $chan] || [matchattr $hand -]}] ; # Note that $chan might be "", so we must handle both cases
        if {([validchan $chan]) && ($isuser)} {
            set output1 $chan ; # The bot sends the text to the channel for users
        } else {
            set output1 $nick ; # Non-users get privmsg'd
        }
        if {[set i [string last ">" $arg]] == -1} {
            set output2 $output1 ; # By default, output2 (~stdout~) goes to output1 (~stderr~)
        } else {
            # Output has been redirected
            if {(!$isuser) || ([set output2 [string trim [string range $arg [expr $i + 1] end] " "]] == "")} {
                set output2 $output1 ; # Error (User doesn't have access, or output was ""), so we go back to the default
            }
            set arg [string trim [string range $arg 0 [expr $i - 1]] " "]
        }
        set remainder [xrange $arg 0 end]
        if {(([scan $remainder "%s from %s to %s" value type1 type2] != 3) || ([anymatch [list $value $type1 $type2] {from to}])) && \
            (([scan $remainder "%s from %s %s"    value type1 type2] != 3) || ([anymatch [list $value $type1 $type2] {from to}])) && \
            (([scan $remainder "%s %s to %s"      value type1 type2] != 3) || ([anymatch [list $value $type1 $type2] {from to}])) && \
            (([scan $remainder "%s %s %s"         value type1 type2] != 3) || ([anymatch [list $value $type1 $type2] {from to}])) && \
            ((([info exists value]) && ([unset value] == "")) || 1) && \
            (([scan $remainder "from %s to %s"    type1 type2] != 2) || ([anymatch [list $type1 $type2] {from to}])) && \
            (([scan $remainder "from %s %s"       type1 type2] != 2) || ([anymatch [list $type1 $type2] {from to}])) && \
            (([scan $remainder "%s to %s"         type1 type2] != 2) || ([anymatch [list $type1 $type2] {from to}])) && \
            (([scan $remainder "%s %s"            type1 type2] != 2) || ([anymatch [list $type1 $type2] {from to}]))} {
            conv_msg $output1 "error parsing sentence"
        } else {
            if {![info exists value]} {
                set value 1
            }
            if {![catch {conv $value       $type1 "misc_from" [array names conv_misc_from]} type1_value]} {
                if {[catch {conv $type1_value $type2 "misc_to"   $list} type2_value]} {
                    conv_msg $output1 "error $type2_value"
                } else {
                    conv_msg $output2 "$value $type1 = $type2_value $type2"
                }
            } elseif {($conv_units_exec != "") && (![catch {conv_units $value $type1 $type2} output])} {
                conv_msg $output2 $output
            } else {
                set type1_formula $type1
                set type2_formula $type2
                set found 0
                while 1 {
                    if {[conv_scan "type1_formula" "type1_unit" 0]} {
                        if {![conv_scan "type2_formula" "type2_unit" 0]} {
                            conv_msg $output1 "error unmatched type '$type1_unit'"
                        } elseif {[catch {conv 1 $type1_unit "unit" [array names conv_unit]} type1_value]} {
                            conv_msg $output1 "error $type1_value"
                        } elseif {![regsub -nocase $type1_unit $type1_formula $type1_value type1_formula]} {
                            conv_msg $output1 "error decompiling expression '$type1_unit'"
                        } elseif {[catch {conv 1 $type2_unit "unit" $list} type2_value]} {
                            conv_msg $output1 "error $type2_value"
                        } elseif {![regsub -nocase $type2_unit $type2_formula $type2_value type2_formula]} {
                            conv_msg $output1 "error decompiling expression '$type2_unit'"
                        } else {
                            incr found
                            continue
                        }
                    } elseif {[conv_scan "type2_formula" "type2_unit" 0]} {
                        conv_msg $output1 "error unmatched type '$type2_unit'"
                    } else {
                        break
                    } ; # At the end, so stop
                    return ; # We got an error somewhere, bail out
                }
                if {!$found} {
                    conv_msg $output1 "error no conversion types found"
                } elseif {[catch {expr [conv_fixexpr "($value) * ($type1_formula) / ($type2_formula)"]} value2]} {
                    conv_msg $output1 "error evaluating expression"
                } else {
                    conv_msg $output2 "$value $type1 = $value2 $type2"
                }
            }
        }
    }
}
# End Public binds code

# Init stuff
if {[catch {package require Tcl 8.3} error]} {
    putlog "error TCL v8.3 or higher is required to run this script"
    return 0
}

putlog "*** LOADED: convert.tcl"

#### faq.tcl v1.0.0 ############################################################
################################################################################
## Written by:                                                                ##
##   KuNgFo0  (http://www.eggfaq.com/).                                       ##
##                                                                            ##
## Modified by:                                                               ##
##   Brian Schmidt aka. brianMan.                                             ##
################################################################################

#### Readme / Help #############################################################
################################################################################
## This script is ripped from KuNgFoO's ib.tcl v3.19 (infobot) script.        ##
################################################################################

#### Changelog #################################################################
################################################################################
## v1.0.0                                                                     ##
## + Initial release.                                                         ##
## + Added the possibility to control which channels could use the commands   ##
##   with a channel flag.                                                     ##
## * Applied a dirty hack to solve a minor redirection bug, which caused all  ##
##   add/append/remove commands that contained a > to break the script.       ##
################################################################################

# Set next line as the directory where the database files are
# located (no other files should be in the same dir)
set faq_dir "data/"

# Set the next line as the default database to save changes to
set faq_database "FooBot.dat"

# What should the channel flag be, to enable the FAQ for that channel?
set faq_channel_flag "faq"

# The default value should be ok for the next two:
# Set the next line as the format to display time in (without timezone)
set faq_format_notz "%H:%M:%S - %A, %B %d, %Y"

# Set the next line as the format to display time in (with timezone)
set faq_format "$faq_format_notz %Z"

# Set the next line as the maxinum number of matches to
# return on searches
set faq_max 5

# Set the next line as the maxinum number of lines to
# return publicly
set faq_max_lines 3

# Set the next line as the flag required to add/remove
# questions and etc
set faq_flag "+f"

# Set the next line as how often to save changes to the database
# (in minutes)
set faq_time 10

proc xrange {xr xr1 xr2} {
    return [join [lrange [split $xr] $xr1 $xr2]]
}

proc xindex {xr xr1} {
    return [join [lrange [split $xr] $xr1 $xr1]]
}

proc validnum {num} {
    return [expr [scan $num "%f%s" a b] == 1]
}

proc anymatch {string1 string2} {
    foreach string $string2 {
        if {[lsearch -exact [string tolower $string1] [string tolower $string]] != -1} {
            return 1
        }
    }
    return 0
}

proc parseurl {url} {
    foreach var {protocol user pass server port path cgiargs anchor} { upvar 1 $var $var }
    if {[regexp {(([^:]+)://)?(([^:]+):([^@]+)@)?([^:/\?#]+)(:([0-9]+))?(/([^\?#]+))?(\?([^#]+))?(#(.*))?} $url a b protocol c user pass server d port e path f cgiargs g anchor]} {
        if {$protocol == ""} {
            set protocol "http"
        }
        if {![validnum $port]} {
            set port 80
        }
        return 1
    } else {
        return 0
    }
}

# Begin Database code
proc faq_fixtopic {arg} {
    regsub -all {[\\\{\}\[\]\"]} $arg {}   arg ; # Bad characters
    regsub -all {(\s)+}          $arg {\1} arg ; # Double whitespace
    regsub -all {^\s*|\s*$}      $arg {}   arg ; # Whitespace at ends
    return $arg
}

proc faq_fixdb {arg} {
    global faq_databases
    if {[set i [lsearch -exact [string tolower $faq_databases] [string tolower $arg]]] == -1} {
        return "error no such database '$arg' loaded"
    } else {
        return [lindex $faq_databases $i]
    }
}

proc faq_fixdata {arg output} {
    global botnick
    if {[string index $output 0] != "#"} {
        regsub -all -nocase {$output's} $arg "your" arg
    }
    regsub -all -nocase {$botnick's} $arg "my" arg
    return $arg
}

proc faq_msg {targets arg} {
    foreach target $targets {
        puthelp "PRIVMSG $target :[faq_fixdata $arg $target]"
    }
}

proc faq_check {} {
    global faq_dir
    if {![file exists $faq_dir]} {
        return "error $faq_dir does not exist"
    } elseif {![file isdirectory $faq_dir]} {
        return "error $faq_dir is not a directory"
    } elseif {![file readable $faq_dir]} {
        return "error $faq_dir is unreadable"
    } elseif {![file writable $faq_dir]} {
        return "error $faq_dir is unwritable"
    }
    return ""
}

proc faq_loadall {output1 output2} {
    global faq_dir faq_databases
    # Unset current databases first
    faq_unloadall
    if {[set error [faq_check]] != ""} {
        if {$output1 == ""} {
            putlog $error
        } else {
            faq_msg $output1 $error
        }
    } else {
        foreach file [glob -nocomplain [file join $faq_dir *]] {
            if {[file isfile $file]} {
                if {[xindex [set output [faq_load [file tail $file]]] 0] == "error"} {
                    if {$output1 == ""} {
                        putlog $output
                    } else {
                        faq_msg $output1 $output
                    }
                } else {
                    if {$output2 == ""} {
                        putlog $output
                    } else {
                        faq_msg $output2 $output
                    }
                }
            }
        }
    }
}

proc faq_load {database} {
    global faq_dir faq_databases faq_data_$database
    set file [file join $faq_dir $database]
    faq_unload $database
    if {([string match *..* $database]) || ([string index $database 0] == "/")} {
        return "error invalid database name '$database'"
    } elseif {![file exists $file]} {
        return "error database '$database' does not exist"
    } elseif {![file isfile $file]} {
        return "error database '$database' is not a valid file"
    } elseif {[catch {open $file r} fileid]} {
        return "error could not read database '$database'"
    } else {
        if {[catch {array set faq_data_$database [read $fileid]}]} {
            return "error could not parse database '$database'"
        }
        close $fileid
        lappend faq_databases $database
        return "read database '$database'"
    }
}

proc faq_unloadall {} {
    global faq_databases
    if {[info exists faq_databases]} {
        foreach database $faq_databases {
            faq_unload $database
        }
    }
    set faq_databases ""
}

proc faq_unload {database} {
    global faq_databases faq_data_$database
    if {[array exists faq_data_$database]} {
        array unset faq_data_$database
    }
    if {[set i [lsearch -exact $faq_databases $database]] != -1} {
        set faq_databases [lreplace $faq_databases $i $i]
    }
}

proc faq_saveall {output1 output2} {
    global faq_databases faq_save
    set error 0
    if {[set output [faq_check]] != ""} {
        if {$output1 == ""} {
            putlog $error
        } else {
            faq_msg $output1 $output
        }
        set error 1
    } else {
        foreach database $faq_databases {
            if {[xindex [set output [faq_save $database]] 0] == "error"} {
                if {$output1 == ""} {
                    putlog $output
                } else {
                    faq_msg $output1 $output
                }
                set error 1
            } else {
                if {$output2 == ""} {
                    putlog $output
                } else {
                    faq_msg $output2 $output
                }
            }
        }
    }
    set faq_save $error
}

proc faq_save {database} {
    global faq_dir faq_databases faq_data_$database
    if {[catch {open [file join $faq_dir $database] w} fileid]} {
        return "error could not write database 'database'"
    } else {
        puts $fileid [array get faq_data_$database]
        close $fileid
        return "wrote database '$database'"
    }
}

proc faq_needsave {} {
    global faq_save
    set faq_save 1
}

proc time_faq {} {
    global faq_time faq_save
    if {$faq_save} {
        faq_saveall "" ""
    }
    if {![string match *time_faq* [timers]]} {
        timer $faq_time time_faq
    }
}

proc faq_topics {arg} {
    set topics ""
    set arg    [string trimright $arg "?! "]
    set length [llength $arg]
    for {set l $length} {$l > 0} {incr l -1} {
        for {set i [expr $length - $l]} {$i >= 0} {incr i -1} {
            if {[lsearch -exact [string tolower $topics] [string tolower [set topic [lrange $arg $i [expr $i + $l - 1]]]]] == -1} {
                lappend topics $topic
            }
        }
    }
    return $topics
}

# {"topic 1" "topic 2" ...} -> faq_find -> {"database" "first topic found"}
# note: databases are not checked for validity
proc faq_find {topics} {
    global faq_databases
    foreach topic $topics {
        set topic [faq_fixtopic $topic]
        foreach database $faq_databases {
            if {[xindex [set topic2 [faq_exists $topic $database 1]] 0] != "error"} {
                return [list $database $topic2]
            }
        }
    }
}

# "*topic string*" -> faq_find2 -> { {"database" "topic found 1"} {"database" "topic found 2"} ... }
proc faq_find2 {topic} {
    global faq_databases
    set topic  [faq_fixtopic $topic]
    set topics ""
    foreach database $faq_databases {
        global faq_data_$database
        # [array names faq_data_$database -glob *topic*] would be really nice here, but it has no -nocase option!
        foreach topic2 [array names faq_data_$database] {
            if {[string match -nocase *$topic* $topic2]} {
                lappend topics [list $database $topic2]
            }
        }
    }
    return $topics
}

proc faq_parsetopic {arg var1 var2} {
    global $var1 $var2
    set i     [string first "=" $arg]
    set $var1 [string trim [string range $arg 0 [expr $i - 1]] " "]
    set $var2 [string trim [string range $arg [expr $i + 1] end] " "]
    for {set i 1} {$i <= 2} {incr i} {
        if {[string match "topic*" [set topic_var [set var$i]]]} {
            # if this is a topic, we look for a database too
            set database_var "database[string range $topic_var 5 end]"
            if {[xindex [set error [faq_parsedb [set $topic_var] $topic_var $database_var]] 0] == "error"} {
                return $error
            } ; # we got an error parsing the db
        }
    }
    if {([set $var1] == "") || ([set $var2] == "") || ($i == -1)} {
        return "error parsing sentence"
    }
}

proc faq_parsedb {arg var1 var2} {
    global faq_database $var1 $var2
    if {[set i [string last "|" $arg]] != -1} {
        set $var1 [string trim [string range $arg 0 [expr $i - 1]] " "]
        set $var2 [string trim [string range $arg [expr $i + 1] end] " "]
    } else {
        if {[set tmp [faq_find [list $arg]]] != ""} {
            set $var2 [lindex $tmp 0] ; # we go with the db that this topic is already stored in
        } else {
            set $var2 $faq_database ; # we go w/ default db
        }
    }
    if {([set $var1 [faq_fixtopic [set $var1]]] == "") || ([set $var2] == "")} {
        return "error parsing sentence"
    }
    return [set $var2 [faq_fixdb [set $var2]]] ; # this may return an error
}

# type = 0, returns 1/0 ; type = 1, returns proper case (or error), for use with existing topics ;
# type = 2, returns proper case (or original topic), for use with creating new topics
proc faq_exists {topic database type} {
    global faq_data_$database
    if {[set i [lsearch [string tolower [array names faq_data_$database]] [string tolower $topic]]] != -1} {
        if {$type == 0} {
            return 1
        } else {
            return [lindex [array names faq_data_$database] $i]
        }
    } else {
        if {$type == 0} {
            return 0
        } elseif {$type == 1} {
            return "error topic '$topic' does not exist in database '$database'"
        } else {
            return $topic
        }
    }
}

proc faq_write {topic database type arg host} {
    global faq_data_$database
    set topic [faq_exists $topic $database 2]
    if {$type == "w"} {
        set faq_data_${database}($topic) [list $arg]
    } elseif {$type == "a"} {
        lappend faq_data_${database}($topic) $arg
    }
    lappend faq_data_${database}($topic) "#WHOSET $host [clock seconds]"
}

proc faq_read {topic database} {
    global faq_data_$database
    if {[xindex [set database [faq_fixdb $database]] 0] == "error"} {
        return $database
    } elseif {[xindex [set topic [faq_exists $topic $database 1]] 0] == "error"} {
        return $topic
    } else {
        return [set faq_data_${database}($topic)]
    }
}

proc faq_copy {topic1 database1 topic2 database2} {
    global faq_data_$database1 faq_data_$database2
    if {[faq_exists $topic2 $database2 0]} {
        return "error topic '$topic2' already exists in database '$database2'"
    } elseif {[xindex [set output [faq_read $topic1 $database1]] 0] == "error"} {
        return $output
    } else {
        set faq_data_${database2}($topic2) $output
    }
}

proc faq_remove {topic database} {
    global faq_data_$database
    if {[xindex [set topic [faq_exists $topic $database 1]] 0] == "error"} {
        return $topic
    } else {
        unset faq_data_${database}($topic)
    }
}

proc faq_disp {arg database output1 output2 depth num option nick} {
    global faq_max_lines
    if {$depth >= 3} {
        faq_msg $output1 "error recursion too deep"
        return -1
    }
    set found 0
    if {$database != ""} {
        set list [list [list $database $arg]] ; # we have an exact topic/db to display
    } else {
        set list [list [faq_find [faq_topics $arg]]]; # find topic/db (s)
    }
    # note: the $list vars above needed to be padded with { } - hence the [list] 's
    foreach tmp $list {
        if {$tmp == ""} {
            continue
        }
        if {!$depth} {
            set num 0
        }
        if {[xindex [set output [faq_read [set topic [lindex $tmp 1]] [set database [lindex $tmp 0]]]] 0] == "error"} {
            faq_msg $output1 $output
        } else {
            foreach line $output {
                if {($line == "") || ([xindex $line 0] == "#WHOSET")} {
                    #ignore
                } elseif {[xindex $line 0] == "#LINK"} {
                    if {[set temp [faq_disp [lindex $line 1] [lindex $line 2] $output1 $output2 [expr $depth + 1] $num 0 $nick]] > 0} {
                        incr num $temp
                    }
                } elseif {[xindex $line 0] == "."} {
                    faq_msg $output2 [xrange $line 1 end]
                    incr num
                } elseif {!$num} {
                    faq_msg $output2 "$topic - $line"
                    incr num
                } else {
                    faq_msg $output2 "... $line"
                    incr num
                }
            }
            if {!$num} {
                faq_msg $output1 "error '$topic' exists, but is empty"
            } elseif {(![string equal -nocase $output2 $output1]) && (!$depth)} {
                faq_msg $output2 "(sent by $output1)"
                faq_msg $output1 "sent '$topic' to $output2"
            }
            incr found
        }
    }
    if {!$found} {
        if {$depth > 0} {
            faq_msg $output1 "error invalid link to '$arg'"
        }
    }
    return $num
}
# End Database code

# Begin 'calc' code
proc faq_fixexpr {exp} {
    global faq_const
    set exp [faq_fixtopic $exp]
    foreach i [array names faq_const] {
        regsub -all "\%$i" $exp $faq_const($i) exp
    }
    return $exp
}
# End 'calc' code

# expr's abs() and int() can't handle large unsigned integers,
# these functions are just to get around this
proc faq_int {value} {
    return [lindex [split $value "."] 0]
}

proc faq_abs {value} {
    return [string trimleft $value "-"]
}

proc faq_absint {value} {
    return [faq_int [faq_abs $value]]
}

# Begin Public binds code
proc msg_faq {nick uhost hand arg} {
    pub_faq $nick $uhost $hand "" $arg
}

proc pub_faq {nick uhost hand chan arg} {
    global botnick faq_dir faq_format faq_max faq_flag faq_database faq_databases faq_channel_flag
    global topic topic1 topic2 database database1 database2 value
    if {(![isbotnick $nick]) && (![matchattr $hand +b]) && ((($chan != "") && ([channel get $chan $faq_channel_flag])) || ($chan == ""))} {
        if {[string match -nocase $botnick* $arg]} {
            set arg [xrange $arg 1 end] ; # Only answer channel messages that begin with the bot's nick
        } elseif {$chan == ""} {
            # Answer all privmsgs
        } else {
            return ; # Msg isn't for us, bail out
        }

        set isuser [expr {[matchattr $hand $faq_flag|$faq_flag $chan] || [matchattr $hand $faq_flag]}] ; # Note that $chan might be "", so we must handle both cases
        if {([validchan $chan]) && ($isuser)} {
            set output1 $chan ; # The bot sends the text to the channel for users
        } else {
            set output1 $nick ; # Non-users get privmsg'd
        }

        set output2 $output1 ; # By default, output2 (~stdout~) goes to output1 (~stderr~)

        if {([lsearch -exact [split "shutup stop sh database db set learn add unset forget delete del remove rem rm erase append addon link join copy cp move mv rename ren"] [string tolower [xindex $arg 0]]] == -1) && ([set i [string last ">" $arg]] != -1)} {
            # Output has been redirected
            if {(!$isuser) || ([set output2 [string trim [string range $arg [expr $i + 1] end] " "]] == "")} {
                set output2 $output1 ; # Error (User doesn't have access, or output was ""), so we go back to the default
            }
            set arg [string trim [string range $arg 0 [expr $i - 1]] " "]
        }

        set command   [string tolower [xindex $arg 0]]
        set remainder [xrange $arg 1 end]
        switch -- $command {
            "shutup" - "stop" - "sh" {
                if {$isuser} {
                    if {[clearqueue help]} {
                        faq_msg $output2 "OK, sorry"
                    } else {
                        faq_msg $output2 "But I'm not saying anything!"
                    }
                }
            }
            "database" - "db" {
                if {$isuser} {
                    switch -- [string tolower [xindex $remainder 0]] {
                        "reload" {
                            faq_loadall $output1 $output2
                        }
                        "save" {
                            faq_saveall $output1 $output2
                        }
                        "list" {
                            set i 1
                            faq_msg $output2 "Loaded database(s):"
                            foreach database $faq_databases {
                                global faq_data_$database
                                faq_msg $output2 [format "%s %-15s %s" $i. $database #[array size faq_data_$database]]
                                incr i
                            }
                            faq_msg $output2 "end"
                        }
                        default {
                            faq_msg $output1 "error must be one of 'reload', 'save' , or 'list'"
                        }
                    }
                }
            }
            "set" - "learn" - "add" {
                if {$isuser} {
                    if {([xindex [set error [faq_parsetopic $remainder topic value]] 0] == "error") || \
                        ([xindex [set error [faq_write $topic $database "w" $value $nick!$uhost]] 0] == "error")} {
                        faq_msg $output1 $error
                    } else {
                        faq_msg $output2 "Set '$topic' in database '$database'"
                        faq_needsave
                    }
                }
            }
            "unset" - "forget" - "delete" - "del" - "remove" - "rem" - "rm" - "erase" {
                if {$isuser} {
                    if {([xindex [set error [faq_parsetopic "$remainder = null" topic value]] 0] == "error") || \
                        ([xindex [set error [faq_remove $topic $database]] 0] == "error")} {
                        faq_msg $output1 $error
                    } else {
                        faq_msg $output2 "Unset '$topic' in database '$database'"
                        faq_needsave
                    }
                }
            }
            "append" - "addon" {
                if {$isuser} {
                    if {([xindex [set error [faq_parsetopic $remainder topic value]] 0] == "error") || \
                        ([xindex [set error [faq_write $topic $database "a" $value $nick!$uhost]] 0] == "error")} {
                        faq_msg $output1 $error
                    } else {
                        faq_msg $output2 "Appended to '$topic' in database '$database'"
                        faq_needsave
                    }
                }
            }
            "link" - "join" {
                if {$isuser} {
                    if {[xindex [set error [faq_parsetopic $remainder topic1 topic2]] 0] == "error"} {
                        faq_msg $output1 $error
                    } elseif {[xindex [set topic2 [faq_exists $topic2 $database2 1]] 0] == "error"} {
                        faq_msg $output1 $topic2 ; # check if 2nd topic exists, get proper casing too (so $topic2 not $error is used)
                    } elseif {[xindex [set error [faq_write $topic1 $database1 "a" [list #LINK $topic2 $database2] $nick!$uhost]] 0] == "error"} {
                        faq_msg $output1 $error
                    } else {
                        faq_msg $output2 "Linked '$topic1' ($database1) to '$topic2' ($database2)"
                        faq_needsave
                    }
                }
            }
            "copy" - "cp" {
                if {$isuser} {
                    if {([xindex [set error [faq_parsetopic $remainder topic1 topic2]] 0] == "error") || \
                        ([xindex [set error [faq_copy $topic1 $database1 $topic2 $database2]] 0] == "error")} {
                        faq_msg $output1 $error
                    } else {
                        faq_msg $output2 "Copied '$topic1' ($database1) to '$topic2' ($database2)"
                        faq_needsave
                    }
                }
            }
            "move" - "mv" - "rename" - "ren" {
                if {$isuser} {
                    if {([xindex [set error [faq_parsetopic $remainder topic1 topic2]] 0] == "error") || \
                        ([xindex [set error [faq_copy $topic1 $database1 $topic2 $database2]] 0] == "error") || \
                        ([xindex [set error [faq_remove $topic1 $database1]] 0] == "error")} {
                        faq_msg $output1 $error
                    } else {
                        faq_msg $output2 "Renamed '$topic1' ($database1) to '$topic2' ($database2)"
                        faq_needsave
                    }
                }
            }
            "list" - "find" - "search" - "locate" {
                set topics [faq_find2 $remainder]
                switch -- [set found [llength $topics]] {
                    0 {
                        faq_msg $output1 "Found no matches to '$remainder'"
                    }
                    1 {
                        faq_disp [join $topics] "" $output1 $output2 0 0 0 $nick
                    }
                    default {
                        faq_msg $output2 "Found $found matches to '$remainder'"
                        set i 1
                        foreach topic $topics {
                            faq_msg $output2 "$i. [lindex $topic 1]"
                            if {$i >= $faq_max} {
                                break
                            }
                            incr i
                        }
                        faq_msg $output2 "end"
                    }
                }
            }
            "whoset" {
                if {[xindex [set error [faq_parsetopic "$remainder = null" topic value]] 0] == "error"} {
                    faq_msg $output1 $error
                } elseif {[xindex [set output [faq_read $topic $database]] 0] == "error"} {
                    faq_msg $output1 $output
                } else {
                    set found 0
                    foreach line $output {
                        if {[xindex $line 0] == "#WHOSET"} {
                            if {!$found} {
                                faq_msg $output2 "'$topic' (database $database) set by [xindex $line 1] on [clock format [xindex $line 2] -format $faq_format]"
                                incr found
                            } else {
                                faq_msg $output2 "... modified by [xindex $line 1] on [clock format [xindex $line 2] -format $faq_format]"
                            }
                        }
                    }
                    if {!$found} {
                        faq_msg $output1 "error could not find who set topic '$topic'"
                    }
                }
            }
            default {
            faq_disp $arg "" $output1 $output2 0 0 1 $nick
            }
        }
    }
}
# End Public binds code

# Init stuff
if {[catch {package require Tcl 8.3} error]} {
    putlog "error TCL v8.3 or higher is required to run this script"
    return 0
}
putlog "*** LOADED: faq.tcl"

bind pubm - * pub_faq
bind msgm - * msg_faq
setudef flag $faq_channel_flag

if {![info exists faq_load]} {
    faq_loadall "" ""
    set faq_load 1
}
if {![info exists faq_save]} {
    set faq_save 0
}
if {![string match *time_faq* [timers]]} {
    timer $faq_time time_faq
}