# fsck function library v1.17
# Copyright (C) 2004-2006 perpleXa
# http://perplexa.ugug.co.uk / #perpleXa on QuakeNet
#
# Redistribution, with or without modification, are permitted provided
# that redistributions retain the above copyright notice, this condition
# and the following disclaimer.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY, to the extent permitted by law; without
# even the implied warranty of MERCHANTABILITY or FITNESS FOR A
# PARTICULAR PURPOSE.
#
# To update this package you need to _RESTART_ your bot.
# A rehash will most likely cause a crash...
#
# You do _not_ need to load any other scripts. This package will do all that
# work for you, just copy it to your scripts directory.
# You can optionally set the script-path variable to let fsck load scripts
# only from directories you specified:
set script-path {
"scripts/swiftirc"
};
#
# This file carries 35 functions, which are listed in alphabetical order below:
# * assert <expression>
# * bytify <integer>
# * cat <file>
# * compiled
# * crypthost <user>
# * delchars <string> <chars>
# * do <body> while <condition>
# * duration <integer>
# * durationtolong <string>
# * Error <source> <severity> <reason>
# * getword <string> <start?-end?>
# * hand2nick:all <hand>
# * initseed
# * iptolong <ip>
# * lines <file>
# * longtoduration <integer>
# * longtoip <integer>
# * merge <arguments ...>
# * minmaxrand <min> <max>
# * mmax <integer> <integer>
# * mmin <integer> <integer>
# * pretty_mask <string>
# * putamsg <text>
# * randstr [minlength] [maxlength] [chars]
# * rputquick <string>
# * sendmail <sender> <recipient> <subject> <message>
# * shuffle <list>
# * sortfile <file>
# * splitline <string> <variable> <maxparams>
# * splitmsg <string>
# * strcom <variable>
# * strreverse <string>
# * strtoul <string>
# * tree <directory>
# * urandom <limit>
# * validip <ip>
#
# Additional features:
# * Prints G-line reasons to the logfile.
#
# * Removes flood triggers for friendly users with one of the +fmno flags.
set NOFLOOD_FOR_FRIENDS 1;
#
# * Loads all other scripts from fsck's parent directory or script-path, using
# enhanced error catching to prevent the bot from crashing when it's loading
# an erroneous script during startup.
set LOAD_ALL_SCRIPTS 1;
# DO NOT EDIT CODE BELOW THIS LINE UNLESS YOU REALLY KNOW WHAT YOU ARE DOING!
# Package stuff
package require Tcl 8.4;
package provide fsck 1.17;
# splitmsg:
# Splits a message into 400byte chunks.
# Some messages exceed the 512 byte buffer of most ircds,
# so here's the solution, this function splits each message
# into a list with 400byte chunks (400+channelname+userhost etc).
# The message will not be split in words, only between them.
proc splitmsg {string} {
set buf1 ""; set buf2 [list];
foreach word [split $string] {
append buf1 " " $word;
if {[string length $buf1]-1 >= 400} {
lappend buf2 [string range $buf1 1 end];
set buf1 "";
}
}
if {$buf1 != ""} {
lappend buf2 [string range $buf1 1 end];
}
return $buf2;
}
# compiled: Gets the eggdrop's file modifytime.
proc compiled {args} {
return [strftime "%d/%m/%y %H:%M" [file mtime [info nameofexecutable]]];
}
# putamsg: Port of mirc's amsg function.
proc putamsg {text} {
set channels [list];
foreach channel [channels] {
if {[botonchan $channel]} {
lappend channels $channel;
}
}
set channels [join $channels ","];
puthelp "PRIVMSG $channels :$text";
}
# hand2nick:all: Returns a list of all users with that hand.
proc hand2nick:all {hand} {
set users [list];
foreach chan [channels] {
foreach user [chanlist $chan] {
if {[string equal -nocase [nick2hand $user] $hand] && ![isbotnick $user]} {
lappend users $user;
}
}
}
return [lsort -unique $users];
}
# pretty_mask:
# Canonify a mask.
# The following transformations are made:
# 1) xxx -> nick!*@*
# 2) xxx.xxx -> *!*@host
# 3) xxx!yyy -> nick!user@*
# 4) xxx@yyy -> *!user@host
# 5) xxx!yyy@zzz -> nick!user@host
proc pretty_mask {mask} {
set star "*";
set retmask "";
set last_dot 0;
set nick $mask;
set user $star;
set host $star;
set char $star;
for {set x 0} {$char != ""} {incr x} {
set char [string index $mask $x]
if {$char == "!"} {
set user [string range $mask [expr $x+1] end];
set host $star;
} elseif {$char == "@"} {
set nick $star;
set user [string range $mask 0 [expr $x-1]];
set host [string range $mask [expr $x+1] end];
} elseif {$char == "."} {
set last_dot $x;
} else {
continue;
}
for {} {$char != ""} {incr x; set char [string index $mask $x]} {
if {$char == "@"} {
set host [string range $mask [expr $x+1] end];
}
}
break;
}
if {$user == $star && $last_dot} {
set nick $star;
set user $star;
set host $mask;
}
if {$nick != $star} {
set char [string first "!" $nick];
set nick [string range $nick 0 [expr {($char > -1) ? $char-1 : "end"}]];
if {$nick == ""} {
set nick $star;
}
}
if {$user != $star} {
set char [string first "@" $user];
set user [string range $user 0 [expr {($char > -1) ? $char-1 : "end"}]];
if {$user == ""} {
set user $star;
}
}
if {$host == ""} {
set host $star;
}
format "%s!%s@%s" $nick $user $host;
}
# duration:
# Converts a specified number of seconds into a duration string.
# Changes to the original duration function:
# * supports milliseconds
# * removed year value
# * sizes between values are always displayed
# i.e. days>0, minutes>0, but hours=0
# will return 1 day 0 hours 3 minutes
proc duration {interval} {
set mseconds [expr ($interval)-int($interval)];
set seconds [expr int($interval)%60];
set minutes [expr (int($interval)%3600)/60];
set hours [expr (int($interval)%(3600*24))/3600];
set days [expr (int($interval)%(3600*24*7))/(3600*24)];
set weeks [expr int($interval)/(3600*24*7)];
set outstring "";
if {$weeks>0} {
append outstring [format "%d week%s " $weeks [expr $weeks==1?"":"s"]];
}
if {$days>0 || ($weeks>0 && ($hours>0 || $minutes>0 || $seconds>0 || $mseconds>0))} {
append outstring [format "%d day%s " $days [expr $days==1?"":"s"]];
}
if {$hours>0 || (($weeks>0 || $days>0) && ($minutes>0 || $seconds>0 || $mseconds>0))} {
append outstring [format "%d hour%s " $hours [expr $hours==1?"":"s"]];
}
if {$minutes>0 || (($weeks>0 || $days>0 || $hours>0) && ($seconds>0 || $mseconds>0))} {
append outstring [format "%d minute%s " $minutes [expr $minutes==1?"":"s"]];
}
if {$mseconds>0} {
append outstring [format "%.3f seconds " [expr $seconds+$mseconds]];
} elseif {$seconds>0} {
append outstring [format "%d second%s " $seconds [expr $seconds==1?"":"s"]];
}
return [string range $outstring 0 end-1];
}
# longtoduration:
# Converts a specified number of seconds into a duration string.
# format: 0 for the "/stats u" compatible output, 1 for more human-friendly output.
proc longtoduration {interval {format 1}} {
if {$interval>=86400 || !$format} {
set seconds [expr $interval%60];
set minutes [expr ($interval%3600)/60];
set hours [expr ($interval%(3600*24))/3600];
set days [expr $interval/(3600*24)];
return [format "%d day%s, %02d:%02d:%02d" $days [expr {($days==1)?"":"s"}] $hours $minutes $seconds];
}
return [duration $interval];
}
# durationtolong:
# Converts the specified string into a number of seconds.
# Valid switches are:
# s (seconds) m (minutes) h (hours) d (days)
# w (weeks) M (months) y (years)
# i.e. 2w3d will return a value of 2 weeks and 3 days.
proc durationtolong {string} {
set total 0;
set current "";
for {set x 0} {$x < [string length $string]} {incr x} {
set ch [string index $string $x];
if {[string is digit -strict $ch]} {
append current $ch;
}
if {$current != ""} {
switch -exact $ch {
"s" {set total [expr $total + $current];}
"m" {set total [expr $total + ($current * 60)];}
"h" {set total [expr $total + ($current * 3600)];}
"d" {set total [expr $total + ($current * 86400)];}
"w" {set total [expr $total + ($current * 604800)];}
"M" {set total [expr $total + ($current * 2592000)];}
"y" {set total [expr $total + ($current * 31557600)];}
}
if {[string match \[smhdwMy\] $ch]} {
set current "";
}
}
}
if {$current != ""} {
set total [expr $total + $current];
}
format "%lu" $total;
}
# bytify: Converts the specifiednumber of bytes into a more human-friendly string.
proc bytify {bytes} {
for {set pos 0; set bytes [expr double($bytes)]} {$bytes >= 1024} {set bytes [expr $bytes/1024]} {
incr pos;
}
set a [lindex {"B" "KB" "MB" "GB" "TB" "PB"} $pos];
format "%.3f%s" $bytes $a;
}
# randstr: Returns a random string of "chars" between min and max.
proc randstr {{min "7"} {max "13"} {chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789\\|[{]}`^-_"}} {
set length [minmaxrand $min $max];
set count [string length $chars];
set result [string index $chars [rand $count]];
for {set index 1} {$index < $length} {incr index} {
append result [string index $chars [rand $count]];
}
return $result;
}
# getword: Gets a word of a string, works independend of multiple spaces.
proc getword {inputstring index} {
if {![regexp {^([[:digit:]]+)-([[:digit:]]+|end)} $index -> index end]} {
set end 0;
}
set inputstring [string trim $inputstring]; set buf "";
set params 0; set instr 1; incr index; catch {incr end;}
for {set i 0} {$i < [string length $inputstring]} {incr i} {
set c [string index $inputstring $i];
if {!($c==" " || $c=="\n" || $c=="\r" || $c=="\t")} {
if {$instr} {
incr params; set instr 0;
}
} else {
set instr 1;
}
if {($params == $index) || (($params >= $index)
&& (($params <= $end) || ($end == "end")))} {
append buf $c;
}
}
return [string trim $buf];
}
# splitline:
# This function splits lines on each space, up to a maximum of maxparams.
# Spaces at the beginning/between words are removed/ignored.
# Multiple spaces in the last parameter will not be removed.
proc splitline {inputstring outputvector maxparams} {
upvar $outputvector cargv;
set cargv [list];
set inputstring [split $inputstring];
set paramcount 0
while {($paramcount<$maxparams || !$maxparams) && $inputstring!=""} {
if {[lindex $inputstring 0]!=""} {
if {[incr paramcount]==$maxparams} {
lappend cargv [join $inputstring];
break;
}
lappend cargv [lindex $inputstring 0];
}
set inputstring [lreplace $inputstring 0 0];
}
return $paramcount;
}
# rputquick: Sends text to the server _without_ any delay.
proc rputquick {text {options ""}} {
# Thread options as this would be the real putquick function.
# Due to sanity checks or something.. :)
if {($options != "")} {
if {![string equal -nocase "-normal" $options]
&& ![string equal -nocase "-next" $options]} {
# Return an error if the specified option is neither -normal nor -next
return -code error "unknown rputquick option: should be one of: -normal -next";
}
}
if {![string equal [string index $text end] "\n"]} {
# Add a newline to the end of the string, if not already.
append text "\n";
}
# Must use catch here, because putdccraw returns a TCL_ERROR
# if we aren't connected to the server and send something.
catch {putdccraw 0 [string length $text] $text;}
return;
}
# http://www.sendmail.org ;)
proc sendmail {sender recipient subject message} {
set sendmail "/usr/sbin/sendmail";
if {[catch {open "|$sendmail $recipient" "w"} fd]} {
return 0;
}
puts $fd "To: $recipient";
puts $fd "From: $sender";
puts $fd "Subject: $subject\n";
puts $fd "$message";
close $fd;
return 1;
}
# crypthost: An encrypted version of getchanhost
# I actually don't know why i made this...
proc crypthost {nick} {
set host [getchanhost $nick];
if {$host == ""} {return;}
set salt $host;
set ident [lindex [split $host "@"] 0];
set host [lindex [split $host "@"] 1];
set crypt [string range [encrypt $salt $host] 0 12];
if {[string index $crypt 0] == "."} {
set crypt "a[string range $crypt 1 12]";
}
if {[string index $crypt 12] == "."} {
set crypt "[string range $crypt 0 11]a";
}
set host [split $host "."];
if {([llength $host] == 4) && [string is digit -strict [lindex $host 3]]} {
set host [join [lrange $host 0 2] "."];
format "%s@%s.%s" $ident $host $crypt;
} else {
set host [join [lrange $host 1 end] "."];
format "%s@qnet-%s.%s" $ident $crypt $host;
}
}
# lines: Counts the lines of a file.
proc lines {file} {
if {[catch {open $file "r"} fp]} {
# We can not open the specified file, return -1
return -1;
}
# Split the whole content on each newline char,
set lines [llength [split [read $fp] "\n"]];
# don't forget to close the file
close $fp;
# and return the list size.
return $lines;
}
# sortfile:
# Sorts a file in alphabetical order.
# USE WITH CARE -- you don't have to worry about the original file
# being untrusted, but you must get it sorted right :)
proc sortfile {file} {
if {[catch {open $file "r"} fp]} {
return -1;
}
set fcont [join [lsort -dictionary [split [read $fp] "\n"]] "\n"];
close $fp;
if {[catch {open $file "w"} fp]} {
return -1;
}
puts $fp $fcont;
close $fp;
return 1;
}
# seed the pseudo-random number generator, rand()
proc initseed {args} {
expr srand([clock clicks -milliseconds]%65536);
}; initseed
# returns a random number from /dev/urandom
proc urandom {limit} {
if {[catch {open "/dev/urandom" "r"} fp]} {
error "Could not open /dev/urandom";
} elseif {![binary scan [read $fp 4] "i" rand]} {
close $fp;
error "Got weird input from /dev/urandom";
} else {
close $fp;
return [expr ($rand & 0x7FFFFFFF) % $limit];
}
}
# shuffle: Randomizes a list.
proc shuffle {list} {
for {set i 0} {$i<[llength $list]} {incr i} {
set j [rand [expr $i+1]];
if {$i == $j} {continue;}
set x [lindex $list $i];
set list [lreplace $list $i $i [lindex $list $j]];
set list [lreplace $list $j $j $x];
}
return $list;
}
# mmin: Returns the shorter value.
proc mmin {a b} {
expr {$a > $b ? $b : $a}
}
# mmax: Returns the longer value.
proc mmax {a b} {
expr {$a < $b ? $b : $a}
}
# minmaxrand: Returns a random number between min and max.
proc minmaxrand {min max} {
expr ([rand [expr ($max - $min)]] + $min);
}
# strcom:
# Strips C style comments from vars.
# Comments in quotes " " will be ignored.
proc strcom {varName} {
upvar $varName string;
set sstring "";
set instr 0;
set incom 0;
for {set i 0} {$i<[string length $string]} {incr i} {
# Get the current char
set c [string index $string $i];
if {$c == "\""} {
# Got a quote, check if it's escaped.
set isesc 0;
for {set x [expr $i-1]} {[string index $string $x] == "\\"} {incr x -1} {
set isesc [expr !$isesc];
}
if {!$isesc && !$incom} {
# It's not escaped.
set instr [expr !$instr];
}
} elseif {$c == "/"} {
# Got a slash, check if we reached begin/end of a comment.
if {!$instr} {
if {$incom} {
# Currently not in string, check if trailing char was *.
if {[string index $string [expr $i-1]] == "*"} {
# End of comment.
set incom 0;
continue;
}
} else {
# Check if following char is *.
if {[string index $string [expr $i+1]] == "*"} {
# Now we are in a comment.
set incom 1;
continue;
}
}
}
}
if {!$incom} {
# Not in comment, add char.
append sstring $c;
}
}
set string $sstring;
}
# delchars: Deletes characters occuring in badchars from string.
proc delchars {string badchars} {
set newstring "";
for {set i 0} {$i < [string length $string]} {incr i} {
set isbad 0;
foreach char [split $badchars ""] {
if {[string index $string $i] == $char} {
set isbad 1;
break;
}
}
if {!$isbad} {
append newstring [string index $string $i];
}
}
return $newstring;
}
# strreverse: Returns the inputstring in reversed order.
proc strreverse {string} {
for {set i 0; set j [expr [string length $string]-1];} {$i < $j} {incr i 1; incr j -1} {
set c [string index $string $i];
set string [string replace $string $i $i [string index $string $j]];
set string [string replace $string $j $j $c];
}
return $string;
}
# validip: Checks an IP for sanity.
proc validip {ip} {
set tmp 0;
if {!([llength [set ip [split $ip "."]]] == 4)} {
return 0;
}
foreach num $ip {
if {[string length $num] > 3 || $num < 0 || $num >= 256} {
return 0;
}
incr tmp $num;
}
expr $tmp>=1;
}
# sevtostring: Returns a string of an error code. (internal function)
proc sevtostring {severity} {
switch -exact $severity {
DEBUG {
return "debug";
}
INFO {
return "info";
}
WARNING {
return "warning";
}
ERROR {
return "error";
}
FATAL {
return "fatal error";
}
default {
return "unknown error";
}
}
}
# Error: Provides enhanced error logging. :)
proc Error {source severity reason} {
putlog [format "%s(%s): %s" [sevtostring $severity] $source $reason];
}
# tree:
# Calls itself recursively and returns the folder content in a tree structure.
# LEAVE THE prefix PARAMETER BLANK! Call it only with the location parameter,
# i.e. [tree "/home/perplexa/.irssi/"]
# Note about the general implementation: The tcl interpreter sets a
# tcl stack limit of 1000 levels to prevent infinite recursions from
# running out of bounds. As this command is implemented recursively it
# will fail for very deeply nested directory structures.
proc tree {location {prefix ""}} {
if {$prefix != ""} {
if {[string index $prefix end-1] == " "} {
set result [list [string range $prefix 0 end-2]`-[lindex [split $location "/"] end]];
} else {
set result [list [string range $prefix 0 end-1]-[lindex [split $location "/"] end]];
}
} else {
set result [list [lindex [split $location "/"] end]];
}
set files [lsort -dictionary [glob -nocomplain "[string trimright $location "/"]/*"]];
set flcnt [llength $files];
for {set i 0} {$i<$flcnt} {incr i} {
set file [lindex $files $i]
if {$i+1 == $flcnt} {
set pre "$prefix`-";
set fpre "$prefix "
} else {
set pre "$prefix|-";
set fpre "$prefix| ";
}
if {[file isdirectory $file]} {
foreach file [tree $file $fpre] {
lappend result $file;
}
} else {
lappend result $pre[lindex [split $file "/"] end];
}
}
return $result;
}
# do: TCL implementation of do while loops.
proc do {body while condition} {
if {$while != "while"} {
return -code error "Invalid function call.";
}
set ccondition [list expr $condition];
while {1} {
uplevel 1 $body;
if {![uplevel 1 $ccondition]} {
break;
}
}
}
# assert: TCL implementation of the C assert function
proc assert {expr} {
set code [catch {uplevel 1 [list expr $expr]} res];
if {$code} {
return -code $code $res;
}
if {![string is boolean -strict $res]} {
return -code error "invalid boolean expression: $expr";
}
if {$res} {return;}
return -code error "assertion failed: $expr";
}
# cat:
# TCL implementation of the UNIX "cat" command.
# Returns the contents of the specified file.
proc cat {file} {
# Don't bother catching errors, just let them propagate up.
set fp [open $file "r"];
# Use the [file size] command to get the size, which preallocates memory,
# rather than trying to grow it as the read progresses.
set size [file size $file];
if {$size} {
set data [read $fp $size];
} else {
# If the file has zero bytes it is either empty, or something
# where [file size] reports 0 but the file actually has data (like
# the files in the /proc filesystem)
set data [read $fp];
}
close $fp;
return $data;
}
# strtol: Converts a string to an unsigned digit.
proc strtoul {string} {
if {[catch {expr int($string)} val]} {
return 0;
}
format "%lu" $val;
}
# merge: Connects arguments.
proc merge {args} {
return [join $args ""];
}
# iptolong: Converts an ip to it's long value.
proc iptolong {ip} {
if {[scan $ip {%[1234567890]%c%[1234567890]%c%[1234567890]%c%[1234567890]} a & b & c & d] != 7} {
return 0;
}
# format "%lu" [expr ((((($a<<8)^$b)<<8)^$c)<<8)^$d];
# fix for 64-bit systems
format "%u" [format "0x%.2X%.2X%.2X%.2X" $a $b $c $d];
}
# longip: Converts the long value of an ip to it's dotted quad ip.
proc longtoip {long} {
format "%u.%u.%u.%u" [expr $long>>24] [expr ($long>>16)&255] [expr ($long>>8)&255] [expr $long&255];
}
# Sends the G-line reason to the logfile if the bot gets banned from a server.
bind raw -|- "465" *raw:fsck:465;
proc *raw:fsck:465 {srv raw str} {
set reason [string range $str [expr [string first ":" $str]+1] end];
Error "server" ERROR "G-lined ($srv): $reason"
return 0;
}
# Removes flood triggers for users with one of the +fmno flags.
bind flud -|- * flood;
proc flood {nick host hand type chan} {
global NOFLOOD_FOR_FRIENDS;
if {[matchattr $hand "fmno|fmno" $chan] && $NOFLOOD_FOR_FRIENDS} {
return 1;
}
return 0;
}
# Load all *.tcl files in either this directory or "script-path".
if {$LOAD_ALL_SCRIPTS} {
putlog "--------------------------------------";
putlog "-------- Initialising scripts --------";
if {![info exists script-path]} {
set script-path [list [file dirname [info script]]];
}
foreach fsck(dir) ${script-path} {
putlog "Current search path:";
putlog $fsck(dir);
set fsck(scripts) [lsort -dictionary [glob -nocomplain -- "[string trimright $fsck(dir) "/"]/*"]];
set fsck(error) "";
set fsck(x) 0; set fsck(y) 0;
foreach fsck(script) $fsck(scripts) {
if {![file isdirectory $fsck(script)] && [string match -nocase *?.tcl $fsck(script)]} {
incr fsck(y);
if {![string compare [info script] $fsck(script)]} {
incr fsck(x);
continue;
}
if {[catch {source $fsck(script)} fsck(error)]} {
Error "fsck" FATAL "Couldn't load $fsck(script) \[$fsck(error)\]";
continue;
}
incr fsck(x);
}
}
putlog "$fsck(x) of $fsck(y) script[expr {($fsck(y) == 1) ? "" : "s"}] initialised.";
}
catch {unset fsck}
}