diff options
| author | Přemysl Eric Janouch <p@janouch.name> | 2021-08-06 16:12:15 +0200 | 
|---|---|---|
| committer | Přemysl Eric Janouch <p@janouch.name> | 2021-08-06 16:43:59 +0200 | 
| commit | 50057d5149dda340b3b47aca4096f4a6ec66b9ee (patch) | |
| tree | 79323d20b17c2c8e32942a1ac9b84d9da3041c6d /plugins/zyklonb | |
| parent | 1f64710e795b0c5434d15813d4f1f568467ca087 (diff) | |
| download | xK-50057d5149dda340b3b47aca4096f4a6ec66b9ee.tar.gz xK-50057d5149dda340b3b47aca4096f4a6ec66b9ee.tar.xz xK-50057d5149dda340b3b47aca4096f4a6ec66b9ee.zip  | |
Come up with sillier names for the binaries
I'm not entirely sure, but it looks like some people might not like
jokes about the Holocaust.
On a more serious note, the project has become more serious over
the 7 or so years of its existence.
Diffstat (limited to 'plugins/zyklonb')
| -rwxr-xr-x | plugins/zyklonb/calc | 241 | ||||
| -rwxr-xr-x | plugins/zyklonb/coin | 128 | ||||
| -rwxr-xr-x | plugins/zyklonb/eval | 312 | ||||
| -rwxr-xr-x | plugins/zyklonb/factoids | 177 | ||||
| -rwxr-xr-x | plugins/zyklonb/pomodoro | 502 | ||||
| -rwxr-xr-x | plugins/zyklonb/script | 2310 | ||||
| -rwxr-xr-x | plugins/zyklonb/seen | 160 | ||||
| -rwxr-xr-x | plugins/zyklonb/seen-import-degesch.pl | 39 | ||||
| -rwxr-xr-x | plugins/zyklonb/youtube | 111 | 
9 files changed, 0 insertions, 3980 deletions
diff --git a/plugins/zyklonb/calc b/plugins/zyklonb/calc deleted file mode 100755 index 8e36357..0000000 --- a/plugins/zyklonb/calc +++ /dev/null @@ -1,241 +0,0 @@ -#!/usr/bin/env guile - -  ZyklonB calc plugin, basic Scheme evaluator - -  Copyright 2016 Přemysl Eric Janouch -  See the file LICENSE for licensing information. - -!# - -(import (rnrs (6))) -(use-modules ((rnrs) :version (6))) - -; --- Message parsing ---------------------------------------------------------- - -(define-record-type message (fields prefix command params)) -(define (parse-message line) -  (let f ([parts '()] [chars (string->list line)]) -    (define (take-word w chars) -      (if (or (null? chars) (eqv? (car chars) #\x20)) -        (f (cons (list->string (reverse w)) parts) -           (if (null? chars) chars (cdr chars))) -        (take-word (cons (car chars) w) (cdr chars)))) -    (if (null? chars) -      (let ([data (reverse parts)]) -        (when (< (length data) 2) -          (error 'parse-message "invalid message")) -        (make-message (car data) (cadr data) (cddr data))) -      (if (null? parts) -        (if (eqv? (car chars) #\:) -          (take-word '() (cdr chars)) -          (f (cons #f parts) chars)) -        (if (eqv? (car chars) #\:) -          (f (cons (list->string (cdr chars)) parts) '()) -          (take-word '() chars)))))) - -; --- Utilities ---------------------------------------------------------------- - -(define (display-exception e port) -  (define (puts . x) -    (for-all (lambda (a) (display a port)) x) -    (newline port)) - -  (define (record-fields rec) -    (let* ([rtd (record-rtd rec)] -           [v (record-type-field-names rtd)] -           [len (vector-length v)]) -      (map (lambda (k i) (cons k ((record-accessor rtd i) rec))) -        (vector->list v) -        (let c ([i len] [ls '()]) -          (if (= i 0) ls (c (- i 1) (cons (- i 1) ls))))))) - -  (puts "Caught " (record-type-name (record-rtd e))) -  (for-all -    (lambda (subtype) -      (puts "  " (record-type-name (record-rtd subtype))) -      (for-all -        (lambda (field) (puts "    " (car field) ": " (cdr field))) -        (record-fields subtype))) -    (simple-conditions e))) - -; XXX - we have to work around Guile's lack of proper eol-style support -(define xc (make-transcoder (latin-1-codec) 'lf 'replace)) -(define irc-input-port (transcoded-port (standard-input-port) xc)) -(define irc-output-port (transcoded-port (standard-output-port) xc)) - -(define (send . message) -  (for-all (lambda (x) (display x irc-output-port)) message) -  (display #\return irc-output-port) -  (newline irc-output-port) -  (flush-output-port irc-output-port)) - -(define (get-line-crlf port) -  (define line (get-line port)) -  (if (eof-object? line) line -    (let ([len (string-length line)]) -      (if (and (> len 0) (eqv? (string-ref line (- len 1)) #\return)) -        (substring line 0 (- len 1)) line)))) - -(define (get-config name) -  (send "ZYKLONB get_config :" name) -  (car (message-params (parse-message (get-line-crlf irc-input-port))))) - -(define (extract-nick prefix) -  (do ([i 0 (+ i 1)] [len (string-length prefix)]) -      ([or (= i len) (char=? #\! (string-ref prefix i))] -       [substring prefix 0 i]))) - -(define (string-after s start) -  (let ([s-len (string-length s)] [with-len (string-length start)]) -    (and (>= s-len with-len) -         (string=? (substring s 0 with-len) start) -         (substring s with-len s-len)))) - -; --- Calculator --------------------------------------------------------------- - -; Evaluator derived from the example in The Scheme Programming Language. -; -; Even though EVAL with a carefully crafted environment would also do a good -; job at sandboxing, it would probably be impossible to limit execution time... - -(define (env-new formals actuals env) -  (cond [(null? formals) env] -        [(symbol? formals) (cons (cons formals actuals) env)] -        [else (cons (cons (car formals) (car actuals)) -                    (env-new (cdr formals) (cdr actuals) env))])) -(define (env-lookup var env) (cdr (assq var env))) -(define (env-assign var val env) (set-cdr! (assq var env) val)) - -(define (check-reductions r) -  (if (= (car r) 0) -    (error 'check-reductions "reduction limit exceeded") -    (set-car! r (- (car r) 1)))) - -; TODO - think about implementing more syntactical constructs, -;   however there's not much point in having anything else in a calculator... -(define (exec expr r env) -  (check-reductions r) -  (cond [(symbol? expr) (env-lookup expr env)] -        [(pair? expr) -         (case (car expr) -           [(quote) (cadr expr)] -           [(lambda) (lambda vals -                       (let ([env (env-new (cadr expr) vals env)]) -                         (let loop ([exprs (cddr expr)]) -                           (if (null? (cdr exprs)) -                             (exec (car exprs) r env) -                             (begin (exec (car exprs) r env) -                                    (loop (cdr exprs)))))))] -           [(if) (if (exec (cadr expr) r env) -                   (exec (caddr expr) r env) -                   (exec (cadddr expr) r env))] -           [(set!) (env-assign (cadr expr) (exec (caddr expr) r env) env)] -           [else (apply (exec (car expr) r env) -                        (map (lambda (x) (exec x r env)) (cdr expr)))])] -        [else expr])) - -(define-syntax forward -  (syntax-rules () -    [(_) '()] -    [(_ a b ...) (cons (cons (quote a) a) (forward b ...))])) - -; ...which can't prevent me from simply importing most of the standard library -(define base-library -  (forward -    ; Equivalence, procedure predicate, booleans -    eqv? eq? equal? procedure? boolean? boolean=? not -    ; numbers, numerical input and output -    number? complex? real? rational? integer?  exact? inexact? exact inexact -    real-valued? rational-valued? integer-valued? number->string string->number -    ; Arithmetic -    = < > <= >= zero? positive? negative? odd? even? finite? infinite? nan? -    min max + * - / abs div-and-mod div mod div0-and-mod0 div0 mod0 -    gcd lcm numerator denominator floor ceiling truncate round -    rationalize exp log sin cos tan asin acos atan sqrt expt -    make-rectangular make-polar real-part imag-part magnitude angle -    ; Pairs and lists -    map for-each cons car cdr caar cadr cdar cddr -    caaar caadr cadar caddr cdaar cdadr cddar cdddr -    caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr -    cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr -    pair? null? list? list length append reverse list-tail list-ref -    ; Symbols -    symbol? symbol=? symbol->string string->symbol -    ; Characters -    char? char=? char<? char>? char<=? char>=?  char->integer integer->char -    ; Strings; XXX - omitted make-string - can cause OOM -    string? string=? string<? string>? string<=? string>=? -    string string-length string-ref substring -    string-append string->list list->string string-for-each string-copy -    ; Vectors; XXX - omitted make-vector - can cause OOM -    vector? vector vector-length vector-ref vector-set! -    vector->list list->vector vector-fill! vector-map vector-for-each -    ; Control features -    apply call/cc values call-with-values dynamic-wind)) -(define extended-library -  (forward -    char-upcase char-downcase char-titlecase char-foldcase -    char-ci=? char-ci<? char-ci>? char-ci<=? char-ci>=? -    char-alphabetic? char-numeric? char-whitespace? -    char-upper-case? char-lower-case? char-title-case? -    string-upcase string-downcase string-titlecase string-foldcase -    string-ci=? string-ci<? string-ci>? string-ci<=? string-ci>=? -    find for-all exists filter partition fold-left fold-right -    remp remove remv remq memp member memv memq assp assoc assv assq cons* -    list-sort vector-sort vector-sort! -    bitwise-not bitwise-and bitwise-ior bitwise-xor bitwise-if -    bitwise-bit-count bitwise-length bitwise-first-bit-set bitwise-bit-set? -    bitwise-copy-bit bitwise-bit-field bitwise-copy-bit-field -    bitwise-arithmetic-shift bitwise-rotate-bit-field bitwise-reverse-bit-field -    bitwise-arithmetic-shift-left bitwise-arithmetic-shift-right -    set-car! set-cdr! string-set! string-fill!)) -(define (interpret expr) -  (exec expr '(2000) (append base-library extended-library))) - -; We could show something a bit nicer but it would be quite Guile-specific -(define (error-string e) -  (map (lambda (x) (string-append " " (symbol->string x))) -    (filter (lambda (x) (not (member x '(&who &message &irritants &guile)))) -      (map (lambda (x) (record-type-name (record-rtd x))) -        (simple-conditions e))))) - -(define (calc input respond) -  (define (stringify x) -    (call-with-string-output-port (lambda (port) (write x port)))) -  (guard (e [else (display-exception e (current-error-port)) -                  (apply respond "caught" (error-string e))]) -    (let* ([input (open-string-input-port input)] -           [data (let loop () -                   (define datum (get-datum input)) -                   (if (eof-object? datum) '() (cons datum (loop))))]) -      (call-with-values -        (lambda () (interpret (list (append '(lambda ()) data)))) -        (lambda message -          (for-all (lambda (x) (respond (stringify x))) message)))))) - -; --- Main loop ---------------------------------------------------------------- - -(define prefix (get-config "prefix")) -(send "ZYKLONB register") - -(define (process msg) -  (when (string-ci=? (message-command msg) "PRIVMSG") -    (let* ([nick (extract-nick (message-prefix msg))] -           [target (car (message-params msg))] -           [response-begin -             (apply string-append "PRIVMSG " -               (if (memv (string-ref target 0) (string->list "#&!+")) -                 `(,target " :" ,nick ": ") `(,nick " :")))] -           [respond (lambda args (apply send response-begin args))] -           [text (cadr (message-params msg))] -           [input (or (string-after text (string-append prefix "calc ")) -                      (string-after text (string-append prefix "= ")))]) -      (when input (calc input respond))))) - -(let main-loop () -  (define line (get-line-crlf irc-input-port)) -  (unless (eof-object? line) -    (guard (e [else (display-exception e (current-error-port))]) -      (unless (string=? "" line) -        (process (parse-message line)))) -    (main-loop))) diff --git a/plugins/zyklonb/coin b/plugins/zyklonb/coin deleted file mode 100755 index 7dfe923..0000000 --- a/plugins/zyklonb/coin +++ /dev/null @@ -1,128 +0,0 @@ -#!/usr/bin/env tclsh -# -# ZyklonB coin plugin, random number-based utilities -# -# Copyright 2012, 2014 Přemysl Eric Janouch -# See the file LICENSE for licensing information. -# - -# This is a terrible excuse for a programming language and I feel dirty. - -proc parse {line} { -	global msg -	unset -nocomplain msg - -	if [regexp {^:([^ ]*) *(.*)} $line -> prefix rest] { -		set msg(prefix) $prefix -		set line $rest -	} -	if [regexp {^([^ ]*) *(.*)} $line -> command rest] { -		set msg(command) $command -		set line $rest -	} -	while {1} { -		set line [string trimleft $line " "] -		set i [string first " " $line] -		if {$i == -1} { set i [string length $line] } -		if {$i == 0} { break } - -		if {[string index $line 0] == ":"} { -			lappend msg(param) [string range $line 1 end] -			break -		} -		lappend msg(param) [string range $line 0 [expr $i - 1]] -		set line [string range $line $i end] -	} -} - -proc get_config {key} { -	global msg -	puts "ZYKLONB get_config :$key" -	gets stdin line -	parse $line -	return [lindex $msg(param) 0] -} - -proc pmrespond {text} { -	global ctx -	global ctx_quote -	puts "PRIVMSG $ctx :$ctx_quote$text" -} - -fconfigure stdin -translation crlf -encoding iso8859-1 -fconfigure stdout -translation crlf -encoding iso8859-1 - -set prefix [get_config prefix] -puts "ZYKLONB register" - -set eightball [list \ -	"It is certain" \ -	"It is decidedly so" \ -	"Without a doubt" \ -	"Yes - definitely" \ -	"You may rely on it" \ -	"As I see it, yes" \ -	"Most likely" \ -	"Outlook good" \ -	"Yes" \ -	"Signs point to yes" \ -	"Reply hazy, try again" \ -	"Ask again later" \ -	"Better not tell you now" \ -	"Cannot predict now" \ -	"Concentrate and ask again" \ -	"Don't count on it" \ -	"My reply is no" \ -	"My sources say no" \ -	"Outlook not so good" \ -	"Very doubtful"] - -while {[gets stdin line] != -1} { -	parse $line - -	if {! [info exists msg(prefix)] || ! [info exists msg(command)] -		|| $msg(command) != "PRIVMSG" || ! [info exists msg(param)] -		|| [llength $msg(param)] < 2} { continue } - -	regexp {^[^!]*} $msg(prefix) ctx -	if [regexp {^[#&+!]} [lindex $msg(param) 0]] { -		set ctx_quote "$ctx: " -		set ctx [lindex $msg(param) 0] -	} else { set ctx_quote "" } - -	set input [lindex $msg(param) 1] -	set first_chars [string range $input 0 \ -		[expr [string length $prefix] - 1]] -	if {$first_chars != $prefix} { continue } -	set input [string range $input [string length $prefix] end] - -	if {$input == "coin"} { -		if {rand() < 0.5} { -			pmrespond "Heads." -		} else { -			pmrespond "Tails." -		} -	} elseif {[regexp {^dice( +|$)(.*)} $input -> _ args]} { -		if {! [string is integer -strict $args] || $args <= 0} { -			pmrespond "Invalid or missing number." -		} else { -			pmrespond [expr {int($args * rand()) + 1}] -		} -	} elseif {[regexp {^(choose|\?)( +|$)(.*)} $input -> _ _ args]} { -		if {$args == ""} { -			pmrespond "Nothing to choose from." -		} else { -			set c [split $args ",|"] -			pmrespond [string trim [lindex $c \ -				[expr {int([llength $c] * rand())}]]] -		} -	} elseif {[regexp {^eightball( +|$)(.*)} $input -> _ args]} { -		if {$args == ""} { -			pmrespond "You should, you know, ask something." -		} else { -			pmrespond [lindex $eightball \ -				[expr {int([llength $eightball] * rand())}]]. -		} -	} -} - diff --git a/plugins/zyklonb/eval b/plugins/zyklonb/eval deleted file mode 100755 index ccc7f0a..0000000 --- a/plugins/zyklonb/eval +++ /dev/null @@ -1,312 +0,0 @@ -#!/usr/bin/awk -f -# -# ZyklonB eval plugin, LISP-like expression evaluator -# -# Copyright 2013, 2014 Přemysl Eric Janouch -# See the file LICENSE for licensing information. -# - -BEGIN \ -{ -	RS = "\r" -	ORS = "\r\n" -	IGNORECASE = 1 -	srand() - -	prefix = get_config("prefix") - -	print "ZYKLONB register" -	fflush("") - -	# All functions have to be in this particular array -	min_args["int"]    = 1 -	min_args["+"]      = 1 -	min_args["-"]      = 1 -	min_args["*"]      = 1 -	min_args["/"]      = 1 -	min_args["%"]      = 1 -	min_args["^"]      = 1 -	min_args["**"]     = 1 -	min_args["exp"]    = 1 -	min_args["sin"]    = 1 -	min_args["cos"]    = 1 -	min_args["atan2"]  = 2 -	min_args["log"]    = 1 -	min_args["rand"]   = 0 -	min_args["sqrt"]   = 1 - -	min_args["pi"]     = 0 -	min_args["e"]      = 0 - -	min_args["min"]    = 1 -	min_args["max"]    = 1 - -	# Whereas here their presence is only optional -	max_args["int"]    = 1 -	max_args["sin"]    = 1 -	max_args["cos"]    = 1 -	max_args["atan2"]  = 2 -	max_args["log"]    = 1 -	max_args["rand"]   = 0 -	max_args["sqrt"]   = 1 - -	max_args["pi"]     = 0 -	max_args["e"]      = 0 -} - -{ -	parse($0) -} - -msg_command == "PRIVMSG" \ -{ -	# Context = either channel or user nickname -	match(msg_prefix, /^[^!]+/) -	ctx = substr(msg_prefix, RSTART, RLENGTH) -	if (msg_param[0] ~ /^[#&!+]/) -	{ -		ctx_quote = ctx ": " -		ctx = msg_param[0] -	} -	else -		ctx_quote = "" - - -	if (substr(msg_param[1], 1, length(prefix)) == prefix) -	{ -		keyword = "eval" -		text = substr(msg_param[1], 1 + length(prefix)) -	 	if (match(text, "^" keyword "([^A-Za-z0-9].*|$)")) -			process_request(substr(text, 1 + length(keyword))) -	} -} - -{ -	fflush("") -} - -function pmrespond (text) -{ -	print "PRIVMSG " ctx " :" ctx_quote text -} - -function process_request (input,    res, x) -{ -	delete funs -	delete accumulator -	delete n_args - -	res = "" -	fun_top = 0 -	funs[0] = "" -	accumulator[0] = 0 -	n_args[0] = 0 - -	if (match(input, "^[ \t]*")) -		input = substr(input, RLENGTH + 1) -	if (input == "") -		res = "expression missing" - -	while (res == "" && input != "") { -		if (match(input, "^-?[0-9]+\\.?[0-9]*")) { -			x = substr(input, RSTART, RLENGTH) -			input = substr(input, RLENGTH + 1) - -			match(input, "^ *") -			input = substr(input, RLENGTH + 1) - -			res = process_argument(x) -		} else if (match(input, "^[(]([^ ()]+)")) { -			x = substr(input, RSTART + 1, RLENGTH - 1) -			input = substr(input, RLENGTH + 1) - -			match(input, "^ *") -			input = substr(input, RLENGTH + 1) - -			if (!(x in min_args)) { -				res = "undefined function '" x "'" -			} else { -				fun_top++ -				funs[fun_top] = x -				accumulator[fun_top] = 636363 -				n_args[fun_top] = 0 -			} -		} else if (match(input, "^[)] *")) { -			input = substr(input, RLENGTH + 1) -			res = process_end() -		} else -			res = "invalid input at '" substr(input, 1, 10) "...'" -	} - -	if (res == "") { -		if (fun_top != 0) -			res = "unclosed '" funs[fun_top] "'" -		else if (n_args[0] != 1) -			res = "internal error, expected one result" \ -				", got " n_args[0] " instead" -	} - -	if (res == "") -		pmrespond(accumulator[0]) -	else -		pmrespond(res) -} - -function process_argument (arg) -{ -	if (fun_top == 0) { -		if (n_args[0]++ != 0) -			return "too many results, I only expect one" - -		accumulator[0] = arg -		return "" -	} - -	fun = funs[fun_top] -	if (fun in max_args && max_args[fun] <= n_args[fun_top]) -		return "too many operands for " fun - -	if (fun == "int") { -		accumulator[fun_top] = int(arg) -	} else if (fun == "+") { -		if (n_args[fun_top] == 0) -			accumulator[fun_top] = arg -		else -			accumulator[fun_top] += arg -	} else if (fun == "-") { -		if (n_args[fun_top] == 0) -			accumulator[fun_top] = arg -		else -			accumulator[fun_top] -= arg -	} else if (fun == "*") { -		if (n_args[fun_top] == 0) -			accumulator[fun_top] = arg -		else -			accumulator[fun_top] *= arg -	} else if (fun == "/") { -		if (n_args[fun_top] == 0) -			accumulator[fun_top] = arg -		else if (arg == 0) -			return "division by zero" -		else -			accumulator[fun_top] /= arg -	} else if (fun == "%") { -		if (n_args[fun_top] == 0) -			accumulator[fun_top] = arg -		else if (arg == 0) -			return "division by zero" -		else -			accumulator[fun_top] %= arg -	} else if (fun == "^" || fun == "**" || fun == "exp") { -		if (n_args[fun_top] == 0) -			accumulator[fun_top] = arg -		else -			accumulator[fun_top] ^= arg -	} else if (fun == "sin") { -		accumulator[fun_top] = sin(arg) -	} else if (fun == "cos") { -		accumulator[fun_top] = cos(arg) -	} else if (fun == "atan2") { -		if (n_args[fun_top] == 0) -			accumulator[fun_top] = arg -		else -			accumulator[fun_top] = atan2(accumulator[fun_top], arg) -	} else if (fun == "log") { -		accumulator[fun_top] = log(arg) -	} else if (fun == "rand") { -		# Just for completeness, execution never gets here -	} else if (fun == "sqrt") { -		accumulator[fun_top] = sqrt(arg) -	} else if (fun == "min") { -		if (n_args[fun_top] == 0) -			accumulator[fun_top] = arg -		else if (accumulator[fun_top] > arg) -			accumulator[fun_top] = arg -	} else if (fun == "max") { -		if (n_args[fun_top] == 0) -			accumulator[fun_top] = arg -		else if (accumulator[fun_top] < arg) -			accumulator[fun_top] = arg -	} else -		return "internal error, unhandled operands for " fun - -	n_args[fun_top]++ -	return "" -} - -function process_end () -{ -	if (fun_top <= 0) -		return "extraneous ')'" - -	fun = funs[fun_top] -	if (!(fun in min_args)) -		return "internal error, unhandled ')' for '" fun "'" -	if (min_args[fun] > n_args[fun_top]) -		return "not enough operands for '" fun "'" - -	# There's no 'init' function to do it in -	if (fun == "rand") -		accumulator[fun_top] = rand() -	else if (fun == "pi") -		accumulator[fun_top] = 3.141592653589793 -	else if (fun == "e") -		accumulator[fun_top] = 2.718281828459045 - -	return process_argument(accumulator[fun_top--]) -} - -function get_config (key) -{ -	print "ZYKLONB get_config :" key -	fflush("") - -	getline -	parse($0) -	return msg_param[0] -} - -function parse (line,     s, n, id, token) -{ -	s = 1 -	id = 0 - -	# NAWK only uses the first character of RS -	if (line ~ /^\n/) -		line = substr(line, 2) - -	msg_prefix = "" -	msg_command = "" -	delete msg_param - -	n = match(substr(line, s), / |$/) -	while (n) -	{ -		token = substr(line, s, n - 1) -		if (token ~ /^:/) -		{ -			if (s == 1) -				msg_prefix = substr(token, 2) -			else -			{ -				msg_param[id] = substr(line, s + 1) -				break -			} -		} -		else if (!msg_command) -			msg_command = toupper(token) -		else -			msg_param[id++] = token - -		s = s + n -		n = index(substr(line, s), " ") - -		if (!n) -		{ -		       n = length(substr(line, s)) + 1 -		       if (n == 1) -			       break; -		} -	} -} - diff --git a/plugins/zyklonb/factoids b/plugins/zyklonb/factoids deleted file mode 100755 index 431600c..0000000 --- a/plugins/zyklonb/factoids +++ /dev/null @@ -1,177 +0,0 @@ -#!/usr/bin/env perl -# -# ZyklonB factoids plugin -# -# Copyright 2016 Přemysl Eric Janouch <p@janouch.name> -# See the file LICENSE for licensing information. -# - -use strict; -use warnings; -use Text::Wrap; - -# --- IRC protocol ------------------------------------------------------------- - -binmode STDIN;  select STDIN;  $| = 1; $/ = "\r\n"; -binmode STDOUT; select STDOUT; $| = 1; $\ = "\r\n"; - -sub parse ($) { -	chomp (my $line = shift); -	return undef unless my ($nick, $user, $host, $command, $args) = ($line =~ -		qr/^(?::([^! ]*)(?:!([^@]*)@([^ ]*))? +)?([^ ]+)(?: +(.*))?$/o); -	return {nick => $nick, user => $user, host => $host, command => $command, -		args => defined $args ? [$args =~ /:?((?<=:).*|[^ ]+) */og] : []}; -} - -sub bot_print { -	print "ZYKLONB print :${\shift}"; -} - -# --- Initialization ----------------------------------------------------------- - -my %config; -for my $name (qw(prefix)) { -	print "ZYKLONB get_config :$name"; -	$config{$name} = (parse <STDIN>)->{args}->[0]; -} - -print "ZYKLONB register"; - -# --- Database ----------------------------------------------------------------- -# Simple map of (factoid_name => [definitions]); all factoids are separated -# by newlines and definitions by carriage returns.  Both disallowed in IRC. - -sub db_load { -	local $/ = "\n"; -	my ($path) = @_; -	open my $db, "<", $path or return {}; - -	my %entries; -	while (<$db>) { -		chomp; -		my @defs = split "\r"; -		$entries{shift @defs} = \@defs; -	} -	\%entries -} - -sub db_save { -	local $\ = "\n"; -	my ($path, $ref) = @_; -	my $path_new = "$path.new"; -	open my $db, ">", $path_new or die "db save failed: $!"; - -	my %entries = %$ref; -	print $db join "\r", ($_, @{$entries{$_}}) for keys %entries; -	close $db; -	rename $path_new, $path or die "db save failed: $!"; -} - -# --- Factoids ----------------------------------------------------------------- - -my $db_path = 'factoids.db'; -my %db = %{db_load $db_path}; - -sub learn { -	my ($respond, $input) = @_; -	return &$respond("usage: <name> = <definition>") -		unless $input =~ /^([^=]+?)(?:\s+(\d+))?\s*=\s*(.+?)\s*$/; - -	my ($name, $number, $definition) = ($1, $2, $3); -	return &$respond("trailing numbers in names are disallowed") -		if defined $2; -	$db{$name} = [] unless exists $db{$name}; - -	my $entries = $db{$name}; -	return &$respond("duplicate definition") -		if grep { lc $_ eq lc $definition } @$entries; - -	push @$entries, $definition; -	&$respond("saved as #${\scalar @$entries}"); -	db_save $db_path, \%db; -} - -sub check_number { -	my ($respond, $name, $number) = @_; -	my $entries = $db{$name}; -	if ($number > @$entries) { -		&$respond(qq/"$name" has only ${\scalar @$entries} definitions/); -	} elsif (not $number) { -		&$respond("number must not be zero"); -	} else { -		return 1; -	} -	return 0; -} - -sub forget { -	my ($respond, $input) = @_; -	return &$respond("usage: <name> <number>") -		unless $input =~ /^([^=]+?)\s+(\d+)\s*$/; - -	my ($name, $number) = ($1, int($2)); -	return &$respond(qq/"$name" is undefined/) -		unless exists $db{$name}; - -	my $entries = $db{$name}; -	return unless check_number $respond, $name, $number; - -	splice @$entries, --$number, 1; -	&$respond("forgotten"); -	db_save $db_path, \%db; -} - -sub whatis { -	my ($respond, $input) = @_; -	return &$respond("usage: <name> [<number>]") -		unless $input =~ /^([^=]+?)(?:\s+(\d+))?\s*$/; - -	my ($name, $number) = ($1, $2); -	return &$respond(qq/"$name" is undefined/) -		unless exists $db{$name}; - -	my $entries = $db{$name}; -	if (defined $number) { -		return unless check_number $respond, $name, $number; -		&$respond(qq/"$name" is #$number $entries->[$number - 1]/); -	} else { -		my $i = 1; -		my $definition = join ", ", map { "#${\$i++} $_" } @{$entries}; -		&$respond(qq/"$name" is $definition/); -	} -} - -sub wildcard { -	my ($respond, $input) = @_; -	$input =~ /=/ ? learn(@_) : whatis(@_); -} - -my %commands = ( -	'learn'  => \&learn, -	'forget' => \&forget, -	'whatis' => \&whatis, -	'??'     => \&wildcard, -); - -# --- Input loop --------------------------------------------------------------- - -while (my $line = <STDIN>) { -	my %msg = %{parse $line}; -	my @args = @{$msg{args}}; - -	# This plugin only bothers to respond to PRIVMSG messages -	next unless $msg{command} eq 'PRIVMSG' and @args >= 2 -		and my ($cmd, $input) = $args[1] =~ /^$config{prefix}(\S+)\s*(.*)/; - -	# So far the only reaction is a PRIVMSG back to the sender, so all the -	# handlers need is a response callback and all arguments to the command -	my ($target => $quote) = ($args[0] =~ /^[#+&!]/) -		? ($args[0] => "$msg{nick}: ") : ($msg{nick} => ''); -	# Wrap all responses so that there's space for our prefix in the message -	my $respond = sub { -		local ($Text::Wrap::columns, $Text::Wrap::unexpand) = 400, 0; -		my $start = "PRIVMSG $target :$quote"; -		print for split "\n", wrap $start, $start, shift; -	}; -	&{$commands{$cmd}}($respond, $input) if exists($commands{$cmd}); -} diff --git a/plugins/zyklonb/pomodoro b/plugins/zyklonb/pomodoro deleted file mode 100755 index 2bb6531..0000000 --- a/plugins/zyklonb/pomodoro +++ /dev/null @@ -1,502 +0,0 @@ -#!/usr/bin/env ruby -# coding: utf-8 -# -# ZyklonB pomodoro plugin -# -# Copyright 2015 Přemysl Eric Janouch -# See the file LICENSE for licensing information. -# - -# --- Simple event loop -------------------------------------------------------- - -# This is more or less a straight-forward port of my C event loop.  It's a bit -# unfortunate that I really have to implement all this in order to get some -# basic asynchronicity but at least I get to exercise my Ruby. - -class TimerEvent -	attr_accessor :index, :when, :callback - -	def initialize (callback) -		raise ArgumentError unless callback.is_a? Proc - -		@index = nil -		@when = nil -		@callback = callback -	end - -	def active? -		@index != nil -	end - -	def until -		return @when - Time.new -	end -end - -class IOEvent -	READ  = 1 << 0 -	WRITE = 1 << 1 - -	attr_accessor :read_index, :write_index, :io, :callback - -	def initialize (io, callback) -		raise ArgumentError unless callback.is_a? Proc - -		@read_index = nil -		@write_index = nil -		@io = io -		@callback = callback -	end -end - -class EventLoop -	def initialize -		@running = false -		@timers = [] -		@readers = [] -		@writers = [] -		@io_to_event = {} -	end - -	def set_timer (timer, timeout) -		raise ArgumentError unless timer.is_a? TimerEvent - -		timer.when = Time.now + timeout -		if timer.index -			heapify_down timer.index -			heapify_up timer.index -		else -			timer.index = @timers.size -			@timers.push timer -			heapify_up timer.index -		end -	end - -	def reset_timer (timer) -		raise ArgumentError unless timer.is_a? TimerEvent -		remove_timer_at timer.index if timer.index -	end - -	def set_io (io_event, events) -		raise ArgumentError unless io_event.is_a? IOEvent -		raise ArgumentError unless events.is_a? Numeric - -		reset_io io_event - -		@io_to_event[io_event.io] = io_event -		if events & IOEvent::READ -			io_event.read_index = @readers.size -			@readers.push io_event.io -		end -		if events & IOEvent::WRITE -			io_event.read_index = @writers.size -			@writers.push io_event.io -		end -	end - -	def reset_io (io_event) -		raise ArgumentError unless io_event.is_a? IOEvent - -		@readers.delete_at io_event.read_index  if io_event.read_index -		@writers.delete_at io_event.write_index if io_event.write_index - -		io_event.read_index = nil -		io_event.write_index = nil - -		@io_to_event.delete io_event.io -	end - -	def run -		@running = true -		while @running do one_iteration end -	end - -	def quit -		@running = false -	end - -private -	def one_iteration -		rs, ws, = IO.select @readers, @writers, [], nearest_timeout -		dispatch_timers -		(Array(rs) | Array(ws)).each do |io| -			@io_to_event[io].callback.call io -		end -	end - -	def dispatch_timers -		now = Time.new -		while not @timers.empty? and @timers[0].when <= now do -			@timers[0].callback.call -			remove_timer_at 0 -		end -	end - -	def nearest_timeout -		return nil if @timers.empty? -		timeout = @timers[0].until -		if timeout < 0 then 0 else timeout end -	end - -	def remove_timer_at (index) -		@timers[index].index = nil -		moved = @timers.pop -		return if index == @timers.size - -		@timers[index] = moved -		@timers[index].index = index -		heapify_down index -	end - -	def swap_timers (a, b) -		@timers[a], @timers[b] = @timers[b], @timers[a] -		@timers[a].index = a -		@timers[b].index = b -	end - -	def heapify_up (index) -		while index != 0 do -			parent = (index - 1) / 2 -			break if @timers[parent].when <= @timers[index].when -			swap_timers index, parent -			index = parent -		end -	end - -	def heapify_down (index) -		loop do -			parent = index -			left  = 2 * index + 1 -			right = 2 * index + 2 - -			lowest = parent -			lowest = left  if left  < @timers.size and -				@timers[left] .when < @timers[lowest].when -			lowest = right if right < @timers.size and -				@timers[right].when < @timers[lowest].when -			break if parent == lowest - -			swap_timers lowest, parent -			index = lowest -		end -	end -end - -# --- IRC protocol ------------------------------------------------------------- - -$stdin.set_encoding 'ASCII-8BIT' -$stdout.set_encoding 'ASCII-8BIT' - -$stdin.sync = true -$stdout.sync = true - -$/ = "\r\n" -$\ = "\r\n" - -RE_MSG = /(?::([^! ]*)(?:!([^@]*)@([^ ]*))? +)?([^ ]+)(?: +(.*))?$/ -RE_ARGS = /:?((?<=:).*|[^ ]+) */ - -def parse (line) -	m = line.match RE_MSG -	return nil if not m - -	nick, user, host, command, args = *m.captures -	args = if args then args.scan(RE_ARGS).flatten else [] end -	[nick, user, host, command, args] -end - -def bot_print (what) -	print "ZYKLONB print :#{what}" -end - -# --- Initialization ----------------------------------------------------------- - -# We can only read in configuration from here so far -# To read it from anywhere else, it has to be done asynchronously -$config = {} -[:prefix].each do |name| -	print "ZYKLONB get_config :#{name}" -	_, _, _, _, args = *parse($stdin.gets.chomp) -	$config[name] = args[0] -end - -print "ZYKLONB register" - -# --- Plugin logic ------------------------------------------------------------- - -# FIXME: this needs a major refactor as it doesn't make much sense at all - -class MessageMeta < Struct.new(:nick, :user, :host, :channel, :ctx, :quote) -	def respond (message) -		print "PRIVMSG #{ctx} :#{quote}#{message}" -	end -end - -class Context -	attr_accessor :nick, :ctx - -	def initialize (meta) -		@nick = meta.nick -		@ctx = meta.ctx -	end - -	def == (other) -		self.class == other.class \ -			and other.nick == @nick \ -			and other.ctx  == @ctx -	end - -	alias eql? == - -	def hash -		@nick.hash ^ @ctx.hash -	end -end - -class PomodoroTimer -	def initialize (context) -		@ctx = context.ctx -		@nicks = [context.nick] - -		@timer_work = TimerEvent.new(lambda { on_work }) -		@timer_rest = TimerEvent.new(lambda { on_rest }) - -		on_work -	end - -	def inform (message) -		# FIXME: it tells the nick even in PM's -		quote = "#{@nicks.join(" ")}: " -		print "PRIVMSG #{@ctx} :#{quote}#{message}" -	end - -	def on_work -		inform "work now!" -		$loop.set_timer @timer_rest, 25 * 60 -	end - -	def on_rest -		inform "rest now!" -		$loop.set_timer @timer_work, 5 * 60 -	end - -	def join (meta) -		return if @nicks.include? meta.nick - -		meta.respond "you have joined their pomodoro" -		@nicks |= [meta.nick] -	end - -	def part (meta, requested) -		return if not @nicks.include? meta.nick - -		if requested -			meta.respond "you have stopped your pomodoro" -		end - -		@nicks -= [meta.nick] -		if @nicks.empty? -			$loop.reset_timer @timer_work -			$loop.reset_timer @timer_rest -		end -	end - -	def status (meta) -		return if not @nicks.include? meta.nick - -		if @timer_rest.active? -			till = @timer_rest.until -			meta.respond "working, #{(till / 60).to_i} minutes, " + -				"#{(till % 60).to_i} seconds until rest" -		end -		if @timer_work.active? -			till = @timer_work.until -			meta.respond "resting, #{(till / 60).to_i} minutes, " + -				"#{(till % 60).to_i} seconds until work" -		end -	end -end - -class Pomodoro -	KEYWORD = "pomodoro" - -	def initialize -		@timers = {} -	end - -	def on_help (meta, args) -		meta.respond "usage: #{KEYWORD} { start | stop | join <nick> | status }" -	end - -	def on_start (meta, args) -		if args.size != 0 -			meta.respond "usage: #{KEYWORD} start" -			return -		end - -		context = Context.new meta -		if @timers[context] -			meta.respond "you already have a timer running here" -		else -			@timers[context] = PomodoroTimer.new meta -		end -	end - -	def on_join (meta, args) -		if args.size != 1 -			meta.respond "usage: #{KEYWORD} join <nick>" -			return -		end - -		context = Context.new meta -		if @timers[context] -			meta.respond "you already have a timer running here" -			return -		end - -		joined_context = Context.new meta -		joined_context.nick = args.shift -		timer = @timers[joined_context] -		if not timer -			meta.respond "that person doesn't have a timer here" -		else -			timer.join meta -			@timers[context] = timer -		end -	end - -	def on_stop (meta, args) -		if args.size != 0 -			meta.respond "usage: #{KEYWORD} stop" -			return -		end - -		context = Context.new meta -		timer = @timers[context] -		if not timer -			meta.respond "you don't have a timer running here" -		else -			timer.part meta, true -			@timers.delete context -		end -	end - -	def on_status (meta, args) -		if args.size != 0 -			meta.respond "usage: #{KEYWORD} status" -			return -		end - -		timer = @timers[Context.new meta] -		if not timer -			meta.respond "you don't have a timer running here" -		else -			timer.status meta -		end -	end - -	def process_command (meta, msg) -		args = msg.split -		return if args.shift != KEYWORD - -		method = "on_#{args.shift}" -		send method, meta, args if respond_to? method -	end - -	def on_server_nick (meta, command, args) -		# TODO: either handle this properly... -		happened = false -		@timers.keys.each do |key| -			next if key.nick != meta.nick -			@timers[key].part meta, false -			@timers.delete key -			happened = true -		end -		if happened -			# TODO: ...or at least inform the user via his new nick -		end -	end - -	def on_server_part (meta, command, args) -		# TODO: instead of cancelling the user's pomodoros, either redirect -		#   them to PM's and later upon rejoining undo the redirection... -		context = Context.new(meta) -		context.ctx = meta.channel -		if @timers.include? context -			# TODO: ...or at least inform the user about the cancellation -			@timers[context].part meta, false -			@timers.delete context -		end -	end - -	def on_server_quit (meta, command, args) -		@timers.keys.each do |key| -			next if key.nick != meta.nick -			@timers[key].part meta, false -			@timers.delete key -		end -	end - -	def process (meta, command, args) -		method = "on_server_#{command.downcase}" -		send method, meta, command, args if respond_to? method -	end -end - -# --- IRC message processing --------------------------------------------------- - -$handlers = [Pomodoro.new] -def process_line (line) -	msg = parse line -	return if not msg - -	nick, user, host, command, args = *msg - -	context = nick -	quote = "" -	channel = nil - -	if args.size >= 1 and args[0].start_with? ?#, ?+, ?&, ?! -		case command -		when "PRIVMSG", "NOTICE", "JOIN" -			context = args[0] -			quote = "#{nick}: " -			channel = args[0] -		when "PART" -			channel = args[0] -		end -	end - -	# Handle any IRC message -	meta = MessageMeta.new(nick, user, host, channel, context, quote).freeze -	$handlers.each do |handler| -		handler.process meta, command, args -	end - -	# Handle pre-processed bot commands -	if command == 'PRIVMSG' and args.size >= 2 -		msg = args[1] -		return unless msg.start_with? $config[:prefix] -		$handlers.each do |handler| -			handler.process_command meta, msg[$config[:prefix].size..-1] -		end -	end -end - -buffer = "" -stdin_io = IOEvent.new($stdin, lambda do |io| -	begin -		buffer << io.read_nonblock(4096) -		lines = buffer.split $/, -1 -		buffer = lines.pop -		lines.each { |line| process_line line } -	rescue EOFError -		$loop.quit -	rescue IO::WaitReadable -		# Ignore -	end -end) - -$loop = EventLoop.new -$loop.set_io stdin_io, IOEvent::READ -$loop.run diff --git a/plugins/zyklonb/script b/plugins/zyklonb/script deleted file mode 100755 index c19b8c5..0000000 --- a/plugins/zyklonb/script +++ /dev/null @@ -1,2310 +0,0 @@ -#!/usr/bin/tcc -run -lm -// -// ZyklonB scripting plugin, using a custom stack-based language -// -// Copyright 2014 Přemysl Eric Janouch -// See the file LICENSE for licensing information. -// -// Just compile this file as usual (sans #!) if you don't feel like using TCC. -// It is a very basic and portable C99 application.  It's not supposed to be -// very sophisticated, for it'd get extremely big. -// -// The main influences of the language were Factor and Joy, stripped of all -// even barely complex stuff.  In its current state, it's only really useful as -// a calculator but it's got great potential for extending. -// -// If you don't like something, just change it; this is just an experiment. -// -// NOTE: it is relatively easy to abuse.  Be careful. -// - -#define _XOPEN_SOURCE 500 - -#include <stdio.h> -#include <stdlib.h> -#include <string.h> -#include <ctype.h> -#include <errno.h> -#include <stdarg.h> -#include <assert.h> -#include <time.h> -#include <stdbool.h> -#include <strings.h> -#include <math.h> - -#define ADDRESS_SPACE_LIMIT (100 * 1024 * 1024) -#include <sys/resource.h> - -#if defined __GNUC__ -#define ATTRIBUTE_PRINTF(x, y) __attribute__ ((format (printf, x, y))) -#else // ! __GNUC__ -#define ATTRIBUTE_PRINTF(x, y) -#endif // ! __GNUC__ - -#define N_ELEMENTS(a) (sizeof (a) / sizeof ((a)[0])) - -// --- Utilities --------------------------------------------------------------- - -static char *strdup_printf (const char *format, ...) ATTRIBUTE_PRINTF (1, 2); - -static char * -strdup_vprintf (const char *format, va_list ap) -{ -	va_list aq; -	va_copy (aq, ap); -	int size = vsnprintf (NULL, 0, format, aq); -	va_end (aq); -	if (size < 0) -		return NULL; - -	char buf[size + 1]; -	size = vsnprintf (buf, sizeof buf, format, ap); -	if (size < 0) -		return NULL; - -	return strdup (buf); -} - -static char * -strdup_printf (const char *format, ...) -{ -	va_list ap; -	va_start (ap, format); -	char *result = strdup_vprintf (format, ap); -	va_end (ap); -	return result; -} - -// --- Generic buffer ---------------------------------------------------------- - -struct buffer -{ -	char *s;                            ///< Buffer data -	size_t alloc;                       ///< Number of bytes allocated -	size_t len;                         ///< Number of bytes used -	bool memory_failure;                ///< Memory allocation failed -}; - -#define BUFFER_INITIALIZER { NULL, 0, 0, false } - -static bool -buffer_append (struct buffer *self, const void *s, size_t n) -{ -	if (self->memory_failure) -		return false; - -	if (!self->s) -		self->s = malloc (self->alloc = 8); -	while (self->len + n > self->alloc) -		self->s = realloc (self->s, self->alloc <<= 1); - -	if (!self->s) -	{ -		self->memory_failure = true; -		return false; -	} - -	memcpy (self->s + self->len, s, n); -	self->len += n; -	return true; -} - -inline static bool -buffer_append_c (struct buffer *self, char c) -{ -	return buffer_append (self, &c, 1); -} - -// --- Data types -------------------------------------------------------------- - -enum item_type -{ -	ITEM_STRING, -	ITEM_WORD, -	ITEM_INTEGER, -	ITEM_FLOAT, -	ITEM_LIST -}; - -struct item -{ -#define ITEM_HEADER                                                            \ -	enum item_type type;                /**< The type of this object        */ \ -	struct item *next;                  /**< Next item on the list/stack    */ - -	ITEM_HEADER -}; - -struct item_string -{ -	ITEM_HEADER -	size_t len;                         ///< Length of the string (sans '\0') -	char value[];                       ///< The null-terminated string value -}; - -#define get_string(item)                                                       \ -	(assert ((item)->type == ITEM_STRING),                                     \ -	 ((struct item_string *)(item))->value) - -/// It looks like a string but it doesn't quack like a string -#define item_word item_string - -#define get_word(item)                                                         \ -	(assert ((item)->type == ITEM_WORD),                                       \ -	 ((struct item_word *)(item))->value) - -struct item_integer -{ -	ITEM_HEADER -	long long value;                    ///< The integer value -}; - -#define get_integer(item)                                                      \ -	(assert ((item)->type == ITEM_INTEGER),                                    \ -	 ((struct item_integer *)(item))->value) - -struct item_float -{ -	ITEM_HEADER -	long double value;                  ///< The floating point value -}; - -#define get_float(item)                                                        \ -	(assert ((item)->type == ITEM_FLOAT),                                      \ -	 ((struct item_float *)(item))->value) - -struct item_list -{ -	ITEM_HEADER -	struct item *head;                  ///< The head of the list -}; - -#define get_list(item)                                                         \ -	(assert ((item)->type == ITEM_LIST),                                       \ -	 ((struct item_list *)(item))->head) - -#define set_list(item, head_)                                                  \ -	(assert ((item)->type == ITEM_LIST),                                       \ -	 item_free_list (((struct item_list *)(item))->head),                      \ -	 ((struct item_list *)(item))->head = (head_)) - -const char * -item_type_to_str (enum item_type type) -{ -	switch (type) -	{ -	case ITEM_STRING:   return "string"; -	case ITEM_WORD:     return "word"; -	case ITEM_INTEGER:  return "integer"; -	case ITEM_FLOAT:    return "float"; -	case ITEM_LIST:     return "list"; -	} -	abort (); -} - -// --- Item management --------------------------------------------------------- - -static void item_free_list (struct item *); -static struct item *new_clone_list (const struct item *); - -static void -item_free (struct item *item) -{ -	if (item->type == ITEM_LIST) -		item_free_list (get_list (item)); -	free (item); -} - -static void -item_free_list (struct item *item) -{ -	while (item) -	{ -		struct item *link = item; -		item = item->next; -		item_free (link); -	} -} - -static struct item * -new_clone (const struct item *item) -{ -	size_t size; -	switch (item->type) -	{ -	case ITEM_STRING: -	case ITEM_WORD: -	{ -		const struct item_string *x = (const struct item_string *) item; -		size = sizeof *x + x->len + 1; -		break; -	} -	case ITEM_INTEGER:  size = sizeof (struct item_integer);  break; -	case ITEM_FLOAT:    size = sizeof (struct item_float);    break; -	case ITEM_LIST:     size = sizeof (struct item_list);     break; -	} - -	struct item *clone = malloc (size); -	if (!clone) -		return NULL; - -	memcpy (clone, item, size); -	if (item->type == ITEM_LIST) -	{ -		struct item_list *x = (struct item_list *) clone; -		if (x->head && !(x->head = new_clone_list (x->head))) -		{ -			free (clone); -			return NULL; -		} -	} -	clone->next = NULL; -	return clone; -} - -static struct item * -new_clone_list (const struct item *item) -{ -	struct item *head = NULL, *clone; -	for (struct item **out = &head; item; item = item->next) -	{ -		if (!(clone = *out = new_clone (item))) -		{ -			item_free_list (head); -			return NULL; -		} -		clone->next = NULL; -		out = &clone->next; -	} -	return head; -} - -static struct item * -new_string (const char *s, ssize_t len) -{ -	if (len < 0) -		len = strlen (s); - -	struct item_string *item = calloc (1, sizeof *item + len + 1); -	if (!item) -		return NULL; - -	item->type = ITEM_STRING; -	item->len = len; -	memcpy (item->value, s, len); -	item->value[len] = '\0'; -	return (struct item *) item; -} - -static struct item * -new_word (const char *s, ssize_t len) -{ -	struct item *item = new_string (s, len); -	if (!item) -		return NULL; - -	item->type = ITEM_WORD; -	return item; -} - -static struct item * -new_integer (long long value) -{ -	struct item_integer *item = calloc (1, sizeof *item); -	if (!item) -		return NULL; - -	item->type = ITEM_INTEGER; -	item->value = value; -	return (struct item *) item; -} - -static struct item * -new_float (long double value) -{ -	struct item_float *item = calloc (1, sizeof *item); -	if (!item) -		return NULL; - -	item->type = ITEM_FLOAT; -	item->value = value; -	return (struct item *) item; -} - -static struct item * -new_list (struct item *head) -{ -	struct item_list *item = calloc (1, sizeof *item); -	if (!item) -		return NULL; - -	item->type = ITEM_LIST; -	item->head = head; -	return (struct item *) item; -} - -// --- Parsing ----------------------------------------------------------------- - -#define PARSE_ERROR_TABLE(XX)                                                  \ -	XX( OK,                  NULL                                  )           \ -	XX( EOF,                 "unexpected end of input"             )           \ -	XX( INVALID_HEXA_ESCAPE, "invalid hexadecimal escape sequence" )           \ -	XX( INVALID_ESCAPE,      "unrecognized escape sequence"        )           \ -	XX( MEMORY,              "memory allocation failure"           )           \ -	XX( FLOAT_RANGE,         "floating point value out of range"   )           \ -	XX( INTEGER_RANGE,       "integer out of range"                )           \ -	XX( INVALID_INPUT,       "invalid input"                       )           \ -	XX( UNEXPECTED_INPUT,    "unexpected input"                    ) - -enum tokenizer_error -{ -#define XX(x, y) PARSE_ERROR_ ## x, -	PARSE_ERROR_TABLE (XX) -#undef XX -	PARSE_ERROR_COUNT -}; - -struct tokenizer -{ -	const char *cursor; -	enum tokenizer_error error; -}; - -static bool -decode_hexa_escape (struct tokenizer *self, struct buffer *buf) -{ -	int i; -	char c, code = 0; - -	for (i = 0; i < 2; i++) -	{ -		c = tolower (*self->cursor); -		if (c >= '0' && c <= '9') -			code = (code << 4) | (c - '0'); -		else if (c >= 'a' && c <= 'f') -			code = (code << 4) | (c - 'a' + 10); -		else -			break; - -		self->cursor++; -	} - -	if (!i) -		return false; - -	buffer_append_c (buf, code); -	return true; -} - -static bool -decode_octal_escape (struct tokenizer *self, struct buffer *buf) -{ -	int i; -	char c, code = 0; - -	for (i = 0; i < 3; i++) -	{ -		c = *self->cursor; -		if (c < '0' || c > '7') -			break; - -		code = (code << 3) | (c - '0'); -		self->cursor++; -	} - -	if (!i) -		return false; - -	buffer_append_c (buf, code); -	return true; -} - -static bool -decode_escape_sequence (struct tokenizer *self, struct buffer *buf) -{ -	// Support some basic escape sequences from the C language -	char c; -	switch ((c = *self->cursor)) -	{ -	case '\0': -		self->error = PARSE_ERROR_EOF; -		return false; -	case 'x': -	case 'X': -		self->cursor++; -		if (decode_hexa_escape (self, buf)) -			return true; - -		self->error = PARSE_ERROR_INVALID_HEXA_ESCAPE; -		return false; -	default: -		if (decode_octal_escape (self, buf)) -			return true; - -		self->cursor++; -		const char *from = "abfnrtv\"\\", *to = "\a\b\f\n\r\t\v\"\\", *x; -		if ((x = strchr (from, c))) -		{ -			buffer_append_c (buf, to[x - from]); -			return true; -		} - -		self->error = PARSE_ERROR_INVALID_ESCAPE; -		return false; -	} -} - -static struct item * -parse_string (struct tokenizer *self) -{ -	struct buffer buf = BUFFER_INITIALIZER; -	struct item *item = NULL; -	char c; - -	while (true) -	switch ((c = *self->cursor++)) -	{ -	case '\0': -		self->cursor--; -		self->error = PARSE_ERROR_EOF; -		goto end; -	case '"': -		if (buf.memory_failure -		 || !(item = new_string (buf.s, buf.len))) -			self->error = PARSE_ERROR_MEMORY; -		goto end; -	case '\\': -		if (decode_escape_sequence (self, &buf)) -			break; -		goto end; -	default: -		buffer_append_c (&buf, c); -	} - -end: -	free (buf.s); -	return item; -} - -static struct item * -try_parse_number (struct tokenizer *self) -{ -	// These two standard library functions can digest a lot of various inputs, -	// including NaN and +/- infinity.  That may get a bit confusing. -	char *float_end; -	errno = 0; -	long double float_value = strtold (self->cursor, &float_end); -	int float_errno = errno; - -	char *int_end; -	errno = 0; -	long long int_value = strtoll (self->cursor, &int_end, 10); -	int int_errno = errno; - -	// If they both fail, then this is most probably not a number. -	if (float_end == int_end && float_end == self->cursor) -		return NULL; - -	// Only use the floating point result if it parses more characters: -	struct item *item; -	if (float_end > int_end) -	{ -		if (float_errno == ERANGE) -		{ -			self->error = PARSE_ERROR_FLOAT_RANGE; -			return NULL; -		} -		self->cursor = float_end; -		if (!(item = new_float (float_value))) -			self->error = PARSE_ERROR_MEMORY; -		return item; -	} -	else -	{ -		if (int_errno == ERANGE) -		{ -			self->error = PARSE_ERROR_INTEGER_RANGE; -			return NULL; -		} -		self->cursor = int_end; -		if (!(item = new_integer (int_value))) -			self->error = PARSE_ERROR_MEMORY; -		return item; -	} -} - -static struct item * -parse_word (struct tokenizer *self) -{ -	struct buffer buf = BUFFER_INITIALIZER; -	struct item *item = NULL; -	char c; - -	// Here we accept almost anything that doesn't break the grammar -	while (!strchr (" []\"", (c = *self->cursor++)) && (unsigned char) c > ' ') -		buffer_append_c (&buf, c); -	self->cursor--; - -	if (buf.memory_failure) -		self->error = PARSE_ERROR_MEMORY; -	else if (!buf.len) -		self->error = PARSE_ERROR_INVALID_INPUT; -	else if (!(item = new_word (buf.s, buf.len))) -		self->error = PARSE_ERROR_MEMORY; - -	free (buf.s); -	return item; -} - -static struct item *parse_item_list (struct tokenizer *); - -static struct item * -parse_list (struct tokenizer *self) -{ -	struct item *list = parse_item_list (self); -	if (self->error) -	{ -		assert (list == NULL); -		return NULL; -	} -	if (!*self->cursor) -	{ -		self->error = PARSE_ERROR_EOF; -		item_free_list (list); -		return NULL; -	} -	assert (*self->cursor == ']'); -	self->cursor++; -	return new_list (list); -} - -static struct item * -parse_item (struct tokenizer *self) -{ -	char c; -	switch ((c = *self->cursor++)) -	{ -	case '[':  return parse_list (self); -	case '"':  return parse_string (self); -	default:; -	} - -	self->cursor--; -	struct item *item = try_parse_number (self); -	if (!item && !self->error) -		item = parse_word (self); -	return item; -} - -static struct item * -parse_item_list (struct tokenizer *self) -{ -	struct item *head = NULL; -	struct item **tail = &head; - -	char c; -	bool expected = true; -	while ((c = *self->cursor) && c != ']') -	{ -		if (isspace (c)) -		{ -			self->cursor++; -			expected = true; -			continue; -		} -		else if (!expected) -		{ -			self->error = PARSE_ERROR_UNEXPECTED_INPUT; -			goto fail; -		} - -		if (!(*tail = parse_item (self))) -			goto fail; -		tail = &(*tail)->next; -		expected = false; -	} -	return head; - -fail: -	item_free_list (head); -	return NULL; -} - -static struct item * -parse (const char *s, const char **error) -{ -	struct tokenizer self = { .cursor = s, .error = PARSE_ERROR_OK }; -	struct item *list = parse_item_list (&self); -	if (!self.error && *self.cursor != '\0') -	{ -		self.error = PARSE_ERROR_UNEXPECTED_INPUT; -		item_free_list (list); -		list = NULL; -	} - -#define XX(x, y) y, -	static const char *strings[PARSE_ERROR_COUNT] = -		{ PARSE_ERROR_TABLE (XX) }; -#undef XX - -	static char error_buf[128]; -	if (self.error && error) -	{ -		snprintf (error_buf, sizeof error_buf, "at character %d: %s", -			(int) (self.cursor - s) + 1, strings[self.error]); -		*error = error_buf; -	} -	return list; -} - -// --- Runtime ----------------------------------------------------------------- - -// TODO: try to think of a _simple_ way to do preemptive multitasking - -struct context -{ -	struct item *stack;                 ///< The current top of the stack -	size_t stack_size;                  ///< Number of items on the stack - -	size_t reduction_count;             ///< # of function calls so far -	size_t reduction_limit;             ///< The hard limit on function calls - -	char *error;                        ///< Error information -	bool error_is_fatal;                ///< Whether the error can be catched -	bool memory_failure;                ///< Memory allocation failure - -	void *user_data;                    ///< User data -}; - -/// Internal handler for a function -typedef bool (*handler_fn) (struct context *); - -struct fn -{ -	struct fn *next;                    ///< The next link in the chain - -	handler_fn handler;                 ///< Internal C handler, or NULL -	struct item *script;                ///< Alternatively runtime code -	char name[];                        ///< The name of the function -}; - -struct fn *g_functions;                 ///< Maps words to functions - -static void -context_init (struct context *ctx) -{ -	ctx->stack = NULL; -	ctx->stack_size = 0; - -	ctx->reduction_count = 0; -	ctx->reduction_limit = 2000; - -	ctx->error = NULL; -	ctx->error_is_fatal = false; -	ctx->memory_failure = false; - -	ctx->user_data = NULL; -} - -static void -context_free (struct context *ctx) -{ -	item_free_list (ctx->stack); -	ctx->stack = NULL; - -	free (ctx->error); -	ctx->error = NULL; -} - -static bool -set_error (struct context *ctx, const char *format, ...) -{ -	free (ctx->error); - -	va_list ap; -	va_start (ap, format); -	ctx->error = strdup_vprintf (format, ap); -	va_end (ap); - -	if (!ctx->error) -		ctx->memory_failure = true; -	return false; -} - -static bool -push (struct context *ctx, struct item *item) -{ -	// The `item' is typically a result from new_<type>(), thus when it is null, -	// that function must have failed.  This is a shortcut for convenience. -	if (!item) -	{ -		ctx->memory_failure = true; -		return false; -	} - -	assert (item->next == NULL); -	item->next = ctx->stack; -	ctx->stack = item; -	ctx->stack_size++; -	return true; -} - -static bool -bump_reductions (struct context *ctx) -{ -	if (++ctx->reduction_count >= ctx->reduction_limit) -	{ -		ctx->error_is_fatal = true; -		return set_error (ctx, "reduction limit reached"); -	} -	return true; -} - -static bool execute (struct context *, struct item *); - -static bool -call_function (struct context *ctx, const char *name) -{ -	struct fn *iter; -	for (iter = g_functions; iter; iter = iter->next) -		if (!strcmp (name, iter->name)) -			goto found; -	return set_error (ctx, "unknown function: %s", name); - -found: -	if (!bump_reductions (ctx)) -		return false; - -	if (iter->handler -		? iter->handler (ctx) -		: execute (ctx, iter->script)) -		return true; - -	// In this case, `error' is NULL -	if (ctx->memory_failure) -		return false; - -	// This creates some form of a stack trace -	char *tmp = ctx->error; -	ctx->error = NULL; -	set_error (ctx, "%s -> %s", name, tmp); -	free (tmp); -	return false; -} - -static void -free_function (struct fn *fn) -{ -	item_free_list (fn->script); -	free (fn); -} - -static void -unregister_function (const char *name) -{ -	for (struct fn **iter = &g_functions; *iter; iter = &(*iter)->next) -		if (!strcmp ((*iter)->name, name)) -		{ -			struct fn *tmp = *iter; -			*iter = tmp->next; -			free_function (tmp); -			break; -		} -} - -static struct fn * -prepend_new_fn (const char *name) -{ -	struct fn *fn = calloc (1, sizeof *fn + strlen (name) + 1); -	if (!fn) -		return NULL; - -	strcpy (fn->name, name); -	fn->next = g_functions; -	return g_functions = fn; -} - -static bool -register_handler (const char *name, handler_fn handler) -{ -	unregister_function (name); -	struct fn *fn = prepend_new_fn (name); -	if (!fn) -		return false; -	fn->handler = handler; -	return true; -} - -static bool -register_script (const char *name, struct item *script) -{ -	unregister_function (name); -	struct fn *fn = prepend_new_fn (name); -	if (!fn) -		return false; -	fn->script = script; -	return true; -} - -static bool -execute (struct context *ctx, struct item *script) -{ -	for (; script; script = script->next) -	{ -		if (script->type != ITEM_WORD) -		{ -			if (!bump_reductions (ctx) -			 || !push (ctx, new_clone (script))) -				return false; -		} -		else if (!call_function (ctx, get_word (script))) -			return false; -	} -	return true; -} - -// --- Runtime library --------------------------------------------------------- - -#define defn(name) static bool name (struct context *ctx) - -#define check_stack(n)                                                         \ -	if (ctx->stack_size < n) {                                                 \ -		set_error (ctx, "stack underflow");                                    \ -		return 0;                                                              \ -	} - -inline static bool -check_stack_safe (struct context *ctx, size_t n) -{ -	check_stack (n); -	return true; -} - -static bool -check_type (struct context *ctx, const void *item_, enum item_type type) -{ -	const struct item *item = item_; -	if (item->type == type) -		return true; - -	return set_error (ctx, "invalid type: expected `%s', got `%s'", -		item_type_to_str (type), item_type_to_str (item->type)); -} - -static struct item * -pop (struct context *ctx) -{ -	check_stack (1); -	struct item *top = ctx->stack; -	ctx->stack = top->next; -	top->next = NULL; -	ctx->stack_size--; -	return top; -} - -// - - Types - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#define defn_is_type(name, item_type)                                          \ -	defn (fn_is_##name) {                                                      \ -		check_stack (1);                                                       \ -		struct item *top = pop (ctx);                                          \ -		push (ctx, new_integer (top->type == (item_type)));                    \ -		item_free (top);                                                       \ -		return true;                                                           \ -	} - -defn_is_type (string,  ITEM_STRING) -defn_is_type (word,    ITEM_WORD) -defn_is_type (integer, ITEM_INTEGER) -defn_is_type (float,   ITEM_FLOAT) -defn_is_type (list,    ITEM_LIST) - -defn (fn_to_string) -{ -	check_stack (1); -	struct item *item = pop (ctx); -	char *value; - -	switch (item->type) -	{ -	case ITEM_WORD: -		item->type = ITEM_STRING; -	case ITEM_STRING: -		return push (ctx, item); - -	case ITEM_FLOAT: -		value = strdup_printf ("%Lf", get_float (item)); -		break; -	case ITEM_INTEGER: -		value = strdup_printf ("%lld", get_integer (item)); -		break; - -	default: -		set_error (ctx, "cannot convert `%s' to `%s'", -			item_type_to_str (item->type), item_type_to_str (ITEM_STRING)); -		item_free (item); -		return false; -	} - -	item_free (item); -	if (!value) -	{ -		ctx->memory_failure = true; -		return false; -	} - -	item = new_string (value, -1); -	free (value); -	return push (ctx, item); -} - -defn (fn_to_integer) -{ -	check_stack (1); -	struct item *item = pop (ctx); -	long long value; - -	switch (item->type) -	{ -	case ITEM_INTEGER: -		return push (ctx, item); -	case ITEM_FLOAT: -		value = get_float (item); -		break; - -	case ITEM_STRING: -	{ -		char *end; -		const char *s = get_string (item); -		value = strtoll (s, &end, 10); -		if (end != s && *s == '\0') -			break; - -		item_free (item); -		return set_error (ctx, "integer conversion error"); -	} - -	default: -		set_error (ctx, "cannot convert `%s' to `%s'", -			item_type_to_str (item->type), item_type_to_str (ITEM_INTEGER)); -		item_free (item); -		return false; -	} - -	item_free (item); -	return push (ctx, new_integer (value)); -} - -defn (fn_to_float) -{ -	check_stack (1); -	struct item *item = pop (ctx); -	long double value; - -	switch (item->type) -	{ -	case ITEM_FLOAT: -		return push (ctx, item); -	case ITEM_INTEGER: -		value = get_integer (item); -		break; - -	case ITEM_STRING: -	{ -		char *end; -		const char *s = get_string (item); -		value = strtold (s, &end); -		if (end != s && *s == '\0') -			break; - -		item_free (item); -		return set_error (ctx, "float conversion error"); -	} - -	default: -		set_error (ctx, "cannot convert `%s' to `%s'", -			item_type_to_str (item->type), item_type_to_str (ITEM_FLOAT)); -		item_free (item); -		return false; -	} - -	item_free (item); -	return push (ctx, new_float (value)); -} - -// - - Miscellaneous - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -defn (fn_length) -{ -	check_stack (1); -	struct item *item = pop (ctx); -	bool success = true; -	switch (item->type) -	{ -	case ITEM_STRING: -		success = push (ctx, new_integer (((struct item_string *) item)->len)); -		break; -	case ITEM_LIST: -	{ -		long long length = 0; -		struct item *iter; -		for (iter = get_list (item); iter; iter = iter->next) -			length++; -		success = push (ctx, new_integer (length)); -		break; -	} -	default: -		success = set_error (ctx, "invalid type"); -	} -	item_free (item); -	return success; -} - -// - - Stack operations  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -defn (fn_dup) -{ -	check_stack (1); -	return push (ctx, new_clone (ctx->stack)); -} - -defn (fn_drop) -{ -	check_stack (1); -	item_free (pop (ctx)); -	return true; -} - -defn (fn_swap) -{ -	check_stack (2); -	struct item *second = pop (ctx), *first = pop (ctx); -	return push (ctx, second) && push (ctx, first); -} - -defn (fn_call) -{ -	check_stack (1); -	struct item *script = pop (ctx); -	bool success = check_type (ctx, script, ITEM_LIST) -		&& execute (ctx, get_list (script)); -	item_free (script); -	return success; -} - -defn (fn_dip) -{ -	check_stack (2); -	struct item *script = pop (ctx); -	struct item *item   = pop (ctx); -	bool success = check_type (ctx, script, ITEM_LIST) -		&& execute (ctx, get_list (script)); -	item_free (script); -	if (!success) -	{ -		item_free (item); -		return false; -	} -	return push (ctx, item); -} - -defn (fn_unit) -{ -	check_stack (1); -	struct item *item = pop (ctx); -	return push (ctx, new_list (item)); -} - -defn (fn_cons) -{ -	check_stack (2); -	struct item *list = pop (ctx); -	struct item *item = pop (ctx); -	if (!check_type (ctx, list, ITEM_LIST)) -	{ -		item_free (list); -		item_free (item); -		return false; -	} -	item->next = get_list (list); -	((struct item_list *) list)->head = item; -	return push (ctx, list); -} - -defn (fn_cat) -{ -	check_stack (2); -	struct item *scnd = pop (ctx); -	struct item *frst = pop (ctx); -	if (!check_type (ctx, frst, ITEM_LIST) -	 || !check_type (ctx, scnd, ITEM_LIST)) -	{ -		item_free (frst); -		item_free (scnd); -		return false; -	} - -	// XXX: we shouldn't have to do this in O(n) -	struct item **tail = &((struct item_list *) frst)->head; -	while (*tail) -		tail = &(*tail)->next; -	*tail = get_list (scnd); - -	((struct item_list *) scnd)->head = NULL; -	item_free (scnd); -	return push (ctx, frst); -} - -defn (fn_uncons) -{ -	check_stack (1); -	struct item *list = pop (ctx); -	if (!check_type (ctx, list, ITEM_LIST)) -		goto fail; -	struct item *first = get_list (list); -	if (!first) -	{ -		set_error (ctx, "list is empty"); -		goto fail; -	} -	((struct item_list *) list)->head = first->next; -	first->next = NULL; -	return push (ctx, first) && push (ctx, list); -fail: -	item_free (list); -	return false; -} - -// - - Logical - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -static bool -to_boolean (struct context *ctx, struct item *item, bool *ok) -{ -	switch (item->type) -	{ -	case ITEM_STRING: -		return *get_string (item) != '\0'; -	case ITEM_INTEGER: -		return get_integer (item) != 0; -	case ITEM_FLOAT: -		return get_float   (item) != 0.; -	default: -		return (*ok = set_error (ctx, "cannot convert `%s' to boolean", -			item_type_to_str (item->type))); -	} -} - -defn (fn_not) -{ -	check_stack (1); -	struct item *item = pop (ctx); -	bool ok = true; -	bool result = !to_boolean (ctx, item, &ok); -	item_free (item); -	return ok && push (ctx, new_integer (result)); -} - -defn (fn_and) -{ -	check_stack (2); -	struct item *op1 = pop (ctx); -	struct item *op2 = pop (ctx); -	bool ok = true; -	bool result = to_boolean (ctx, op1, &ok) && to_boolean (ctx, op2, &ok); -	item_free (op1); -	item_free (op2); -	return ok && push (ctx, new_integer (result)); -} - -defn (fn_or) -{ -	check_stack (2); -	struct item *op1 = pop (ctx); -	struct item *op2 = pop (ctx); -	bool ok = true; -	bool result = to_boolean (ctx, op1, &ok) -		|| !ok || to_boolean (ctx, op2, &ok); -	item_free (op1); -	item_free (op2); -	return ok && push (ctx, new_integer (result)); -} - -// - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -defn (fn_if) -{ -	check_stack (3); -	struct item *else_ = pop (ctx); -	struct item *then_ = pop (ctx); -	struct item *cond_ = pop (ctx); - -	bool ok = true; -	bool condition = to_boolean (ctx, cond_, &ok); -	item_free (cond_); - -	bool success = false; -	if (ok -	 && check_type (ctx, then_, ITEM_LIST) -	 && check_type (ctx, else_, ITEM_LIST)) -		success = execute (ctx, condition -			? get_list (then_) -			: get_list (else_)); - -	item_free (then_); -	item_free (else_); -	return success; -} - -defn (fn_try) -{ -	check_stack (2); -	struct item *catch   = pop (ctx); -	struct item *try     = pop (ctx); -	bool success = false; -	if (!check_type (ctx, try,     ITEM_LIST) -	 || !check_type (ctx, catch,   ITEM_LIST)) -		goto fail; - -	if (!execute (ctx, get_list (try))) -	{ -		if (ctx->memory_failure || ctx->error_is_fatal) -			goto fail; - -		success = push (ctx, new_string (ctx->error, -1)); -		free (ctx->error); -		ctx->error = NULL; - -		if (success) -			success = execute (ctx, get_list (catch)); -	} - -fail: -	item_free (try); -	item_free (catch); -	return success; -} - -defn (fn_map) -{ -	check_stack (2); -	struct item *fn   = pop (ctx); -	struct item *list = pop (ctx); -	if (!check_type (ctx, fn,   ITEM_LIST) -	 || !check_type (ctx, list, ITEM_LIST)) -	{ -		item_free (fn); -		item_free (list); -		return false; -	} - -	bool success = false; -	struct item *result = NULL, **tail = &result; -	for (struct item *iter = get_list (list); iter; iter = iter->next) -	{ -		if (!push (ctx, new_clone (iter)) -		 || !execute (ctx, get_list (fn)) -		 || !check_stack_safe (ctx, 1)) -			goto fail; - -		struct item *item = pop (ctx); -		*tail = item; -		tail = &item->next; -	} -	success = true; - -fail: -	set_list (list, result); -	item_free (fn); -	if (!success) -	{ -		item_free (list); -		return false; -	} -	return push (ctx, list); -} - -defn (fn_filter) -{ -	check_stack (2); -	struct item *fn   = pop (ctx); -	struct item *list = pop (ctx); -	if (!check_type (ctx, fn,   ITEM_LIST) -	 || !check_type (ctx, list, ITEM_LIST)) -	{ -		item_free (fn); -		item_free (list); -		return false; -	} - -	bool success = false; -	bool ok = true; -	struct item *result = NULL, **tail = &result; -	for (struct item *iter = get_list (list); iter; iter = iter->next) -	{ -		if (!push (ctx, new_clone (iter)) -		 || !execute (ctx, get_list (fn)) -		 || !check_stack_safe (ctx, 1)) -			goto fail; - -		struct item *item = pop (ctx); -		bool survived = to_boolean (ctx, item, &ok); -		item_free (item); -		if (!ok) -			goto fail; -		if (!survived) -			continue; - -		if (!(item = new_clone (iter))) -			goto fail; -		*tail = item; -		tail = &item->next; -	} -	success = true; - -fail: -	set_list (list, result); -	item_free (fn); -	if (!success) -	{ -		item_free (list); -		return false; -	} -	return push (ctx, list); -} - -defn (fn_fold) -{ -	check_stack (3); -	struct item *op   = pop (ctx); -	struct item *null = pop (ctx); -	struct item *list = pop (ctx); -	bool success = false; -	if (!check_type (ctx, op,   ITEM_LIST) -	 || !check_type (ctx, list, ITEM_LIST)) -	{ -		item_free (null); -		goto fail; -	} - -	push (ctx, null); -	for (struct item *iter = get_list (list); iter; iter = iter->next) -		if (!push (ctx, new_clone (iter)) -		 || !execute (ctx, get_list (op))) -			goto fail; -	success = true; - -fail: -	item_free (op); -	item_free (list); -	return success; -} - -defn (fn_each) -{ -	check_stack (2); -	struct item *op   = pop (ctx); -	struct item *list = pop (ctx); -	bool success = false; -	if (!check_type (ctx, op,   ITEM_LIST) -	 || !check_type (ctx, list, ITEM_LIST)) -		goto fail; - -	for (struct item *iter = get_list (list); iter; iter = iter->next) -		if (!push (ctx, new_clone (iter)) -		 || !execute (ctx, get_list (op))) -			goto fail; -	success = true; - -fail: -	item_free (op); -	item_free (list); -	return success; -} - -// - - Arithmetic  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -// XXX: why not a `struct item_string *` argument? -static bool -push_repeated_string (struct context *ctx, struct item *op1, struct item *op2) -{ -	struct item_string  *string = (struct item_string  *) op1; -	struct item_integer *repeat = (struct item_integer *) op2; -	assert (string->type == ITEM_STRING); -	assert (repeat->type == ITEM_INTEGER); - -	if (repeat->value < 0) -		return set_error (ctx, "cannot multiply a string by a negative value"); - -	char *buf = NULL; -	size_t len = string->len * repeat->value; -	if (len < string->len && repeat->value != 0) -		goto allocation_fail; - -	buf = malloc (len); -	if (!buf) -		goto allocation_fail; - -	for (size_t i = 0; i < len; i += string->len) -		memcpy (buf + i, string->value, string->len); -	struct item *item = new_string (buf, len); -	free (buf); -	return push (ctx, item); - -allocation_fail: -	ctx->memory_failure = true; -	return false; -} - -defn (fn_times) -{ -	check_stack (2); -	struct item *op2 = pop (ctx); -	struct item *op1 = pop (ctx); - -	bool ok; -	if      (op1->type == ITEM_INTEGER && op2->type == ITEM_INTEGER) -		ok = push (ctx, new_integer (get_integer (op1) * get_integer (op2))); -	else if (op1->type == ITEM_INTEGER && op2->type == ITEM_FLOAT) -		ok = push (ctx, new_float   (get_integer (op1) * get_float   (op2))); -	else if (op1->type == ITEM_FLOAT   && op2->type == ITEM_FLOAT) -		ok = push (ctx, new_float   (get_float   (op1) * get_float   (op2))); -	else if (op1->type == ITEM_FLOAT   && op2->type == ITEM_INTEGER) -		ok = push (ctx, new_float   (get_float   (op1) * get_integer (op2))); -	else if (op1->type == ITEM_INTEGER && op2->type == ITEM_STRING) -		ok = push_repeated_string (ctx, op2, op1); -	else if (op1->type == ITEM_STRING  && op2->type == ITEM_INTEGER) -		ok = push_repeated_string (ctx, op1, op2); -	else -		ok = set_error (ctx, "cannot multiply `%s' and `%s'", -			item_type_to_str (op1->type), item_type_to_str (op2->type)); - -	item_free (op1); -	item_free (op2); -	return ok; -} - -defn (fn_pow) -{ -	check_stack (2); -	struct item *op2 = pop (ctx); -	struct item *op1 = pop (ctx); - -	bool ok; -	if      (op1->type == ITEM_INTEGER && op2->type == ITEM_INTEGER) -		// TODO: implement this properly, outputting an integer -		ok = push (ctx, new_float (powl (get_integer (op1), get_integer (op2)))); -	else if (op1->type == ITEM_INTEGER && op2->type == ITEM_FLOAT) -		ok = push (ctx, new_float (powl (get_integer (op1), get_float   (op2)))); -	else if (op1->type == ITEM_FLOAT   && op2->type == ITEM_FLOAT) -		ok = push (ctx, new_float (powl (get_float   (op1), get_float   (op2)))); -	else if (op1->type == ITEM_FLOAT   && op2->type == ITEM_INTEGER) -		ok = push (ctx, new_float (powl (get_float   (op1), get_integer (op2)))); -	else -		ok = set_error (ctx, "cannot exponentiate `%s' and `%s'", -			item_type_to_str (op1->type), item_type_to_str (op2->type)); - -	item_free (op1); -	item_free (op2); -	return ok; -} - -defn (fn_div) -{ -	check_stack (2); -	struct item *op2 = pop (ctx); -	struct item *op1 = pop (ctx); - -	bool ok; -	if (op1->type == ITEM_INTEGER && op2->type == ITEM_INTEGER) -	{ -		if (get_integer (op2) == 0) -			ok = set_error (ctx, "division by zero"); -		else -			ok = push (ctx, new_integer (get_integer (op1) / get_integer (op2))); -	} -	else if (op1->type == ITEM_INTEGER && op2->type == ITEM_FLOAT) -		ok = push (ctx, new_float (get_integer (op1) / get_float   (op2))); -	else if (op1->type == ITEM_FLOAT   && op2->type == ITEM_FLOAT) -		ok = push (ctx, new_float (get_float   (op1) / get_float   (op2))); -	else if (op1->type == ITEM_FLOAT   && op2->type == ITEM_INTEGER) -		ok = push (ctx, new_float (get_float   (op1) / get_integer (op2))); -	else -		ok = set_error (ctx, "cannot divide `%s' and `%s'", -			item_type_to_str (op1->type), item_type_to_str (op2->type)); - -	item_free (op1); -	item_free (op2); -	return ok; -} - -defn (fn_mod) -{ -	check_stack (2); -	struct item *op2 = pop (ctx); -	struct item *op1 = pop (ctx); - -	bool ok; -	if (op1->type == ITEM_INTEGER && op2->type == ITEM_INTEGER) -	{ -		if (get_integer (op2) == 0) -			ok = set_error (ctx, "division by zero"); -		else -			ok = push (ctx, new_integer (get_integer (op1) % get_integer (op2))); -	} -	else if (op1->type == ITEM_INTEGER && op2->type == ITEM_FLOAT) -		ok = push (ctx, new_float (fmodl (get_integer (op1), get_float   (op2)))); -	else if (op1->type == ITEM_FLOAT   && op2->type == ITEM_FLOAT) -		ok = push (ctx, new_float (fmodl (get_float   (op1), get_float   (op2)))); -	else if (op1->type == ITEM_FLOAT   && op2->type == ITEM_INTEGER) -		ok = push (ctx, new_float (fmodl (get_float   (op1), get_integer (op2)))); -	else -		ok = set_error (ctx, "cannot divide `%s' and `%s'", -			item_type_to_str (op1->type), item_type_to_str (op2->type)); - -	item_free (op1); -	item_free (op2); -	return ok; -} - -static bool -push_concatenated_string (struct context *ctx, -	struct item *op1, struct item *op2) -{ -	struct item_string *s1 = (struct item_string *) op1; -	struct item_string *s2 = (struct item_string *) op2; -	assert (s1->type == ITEM_STRING); -	assert (s2->type == ITEM_STRING); - -	char *buf = NULL; -	size_t len = s1->len + s2->len; -	if (len < s1->len || len < s2->len) -		goto allocation_fail; - -	buf = malloc (len); -	if (!buf) -		goto allocation_fail; - -	memcpy (buf,           s1->value, s1->len); -	memcpy (buf + s1->len, s2->value, s2->len); -	struct item *item = new_string (buf, len); -	free (buf); -	return push (ctx, item); - -allocation_fail: -	ctx->memory_failure = true; -	return false; - -} - -defn (fn_plus) -{ -	check_stack (2); -	struct item *op2 = pop (ctx); -	struct item *op1 = pop (ctx); - -	bool ok; -	if      (op1->type == ITEM_INTEGER && op2->type == ITEM_INTEGER) -		ok = push (ctx, new_integer (get_integer (op1) + get_integer (op2))); -	else if (op1->type == ITEM_INTEGER && op2->type == ITEM_FLOAT) -		ok = push (ctx, new_float   (get_integer (op1) + get_float   (op2))); -	else if (op1->type == ITEM_FLOAT   && op2->type == ITEM_FLOAT) -		ok = push (ctx, new_float   (get_float   (op1) + get_float   (op2))); -	else if (op1->type == ITEM_FLOAT   && op2->type == ITEM_INTEGER) -		ok = push (ctx, new_float   (get_float   (op1) + get_integer (op2))); -	else if (op1->type == ITEM_STRING  && op2->type == ITEM_STRING) -		ok = push_concatenated_string (ctx, op1, op2); -	else -		ok = set_error (ctx, "cannot add `%s' and `%s'", -			item_type_to_str (op1->type), item_type_to_str (op2->type)); - -	item_free (op1); -	item_free (op2); -	return ok; -} - -defn (fn_minus) -{ -	check_stack (2); -	struct item *op2 = pop (ctx); -	struct item *op1 = pop (ctx); - -	bool ok; -	if      (op1->type == ITEM_INTEGER && op2->type == ITEM_INTEGER) -		ok = push (ctx, new_integer (get_integer (op1) - get_integer (op2))); -	else if (op1->type == ITEM_INTEGER && op2->type == ITEM_FLOAT) -		ok = push (ctx, new_float   (get_integer (op1) - get_float   (op2))); -	else if (op1->type == ITEM_FLOAT   && op2->type == ITEM_FLOAT) -		ok = push (ctx, new_float   (get_float   (op1) - get_float   (op2))); -	else if (op1->type == ITEM_FLOAT   && op2->type == ITEM_INTEGER) -		ok = push (ctx, new_float   (get_float   (op1) - get_integer (op2))); -	else -		ok = set_error (ctx, "cannot subtract `%s' and `%s'", -			item_type_to_str (op1->type), item_type_to_str (op2->type)); - -	item_free (op1); -	item_free (op2); -	return ok; -} - -// - - Comparison  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -static int -compare_strings (struct item_string *s1, struct item_string *s2) -{ -	// XXX: not entirely correct wrt. null bytes -	size_t len = (s1->len < s2->len ? s1->len : s2->len) + 1; -	return memcmp (s1->value, s2->value, len); -} - -static bool compare_lists (struct item *, struct item *); - -static bool -compare_list_items (struct item *op1, struct item *op2) -{ -	if (op1->type != op2->type) -		return false; - -	switch (op1->type) -	{ -	case ITEM_STRING: -	case ITEM_WORD: -		return !compare_strings ((struct item_string *) op1, -			(struct item_string *) op2); -	case ITEM_FLOAT: -		return get_float (op1) == get_float (op2); -	case ITEM_INTEGER: -		return get_integer (op1) == get_integer (op2); -	case ITEM_LIST: -		return compare_lists (get_list (op1), get_list (op2)); -	} -	abort (); -} - -static bool -compare_lists (struct item *op1, struct item *op2) -{ -	while (op1 && op2) -	{ -		if (!compare_list_items (op1, op2)) -			return false; - -		op1 = op1->next; -		op2 = op2->next; -	} -	return !op1 && !op2; -} - -defn (fn_eq) -{ -	check_stack (2); -	struct item *op2 = pop (ctx); -	struct item *op1 = pop (ctx); - -	bool ok; -	if      (op1->type == ITEM_INTEGER && op2->type == ITEM_INTEGER) -		ok = push (ctx, new_integer (get_integer (op1) == get_integer (op2))); -	else if (op1->type == ITEM_INTEGER && op2->type == ITEM_FLOAT) -		ok = push (ctx, new_integer (get_integer (op1) == get_float   (op2))); -	else if (op1->type == ITEM_FLOAT   && op2->type == ITEM_FLOAT) -		ok = push (ctx, new_integer (get_float   (op1) == get_float   (op2))); -	else if (op1->type == ITEM_FLOAT   && op2->type == ITEM_INTEGER) -		ok = push (ctx, new_integer (get_float   (op1) == get_integer (op2))); -	else if (op1->type == ITEM_LIST    && op2->type == ITEM_LIST) -		ok = push (ctx, new_integer (compare_lists -			(get_list (op1), get_list (op2)))); -	else if (op1->type == ITEM_STRING  && op2->type == ITEM_STRING) -		ok = push (ctx, new_integer (compare_strings -			((struct item_string *)(op1), (struct item_string *)(op2)) == 0)); -	else -		ok = set_error (ctx, "cannot compare `%s' and `%s'", -			item_type_to_str (op1->type), item_type_to_str (op2->type)); - -	item_free (op1); -	item_free (op2); -	return ok; -} - -defn (fn_lt) -{ -	check_stack (2); -	struct item *op2 = pop (ctx); -	struct item *op1 = pop (ctx); - -	bool ok; -	if      (op1->type == ITEM_INTEGER && op2->type == ITEM_INTEGER) -		ok = push (ctx, new_integer (get_integer (op1) < get_integer (op2))); -	else if (op1->type == ITEM_INTEGER && op2->type == ITEM_FLOAT) -		ok = push (ctx, new_integer (get_integer (op1) < get_float   (op2))); -	else if (op1->type == ITEM_FLOAT   && op2->type == ITEM_FLOAT) -		ok = push (ctx, new_integer (get_float   (op1) < get_float   (op2))); -	else if (op1->type == ITEM_FLOAT   && op2->type == ITEM_INTEGER) -		ok = push (ctx, new_integer (get_float   (op1) < get_integer (op2))); -	else if (op1->type == ITEM_STRING  && op2->type == ITEM_STRING) -		ok = push (ctx, new_integer (compare_strings -			((struct item_string *)(op1), (struct item_string *)(op2)) < 0)); -	else -		ok = set_error (ctx, "cannot compare `%s' and `%s'", -			item_type_to_str (op1->type), item_type_to_str (op2->type)); - -	item_free (op1); -	item_free (op2); -	return ok; -} - -// - - Utilities - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -defn (fn_rand) -{ -	return push (ctx, new_float ((long double) rand () -		/ ((long double) RAND_MAX + 1))); -} - -defn (fn_time) -{ -	return push (ctx, new_integer (time (NULL))); -} - -// XXX: this is a bit too constrained; combines strftime() with gmtime() -defn (fn_strftime) -{ -	check_stack (2); -	struct item *format = pop (ctx); -	struct item *time_  = pop (ctx); -	bool success = false; -	if (!check_type (ctx, time_,  ITEM_INTEGER) -	 || !check_type (ctx, format, ITEM_STRING)) -		goto fail; - -	if (get_integer (time_) < 0) -	{ -		set_error (ctx, "invalid time value"); -		goto fail; -	} - -	char buf[128]; -	time_t time__ = get_integer (time_); -	struct tm tm; -	gmtime_r (&time__, &tm); -	buf[strftime (buf, sizeof buf, get_string (format), &tm)] = '\0'; -	success = push (ctx, new_string (buf, -1)); - -fail: -	item_free (time_); -	item_free (format); -	return success; -} - -// - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -static void item_list_to_str (const struct item *, struct buffer *); - -static void -string_to_str (const struct item_string *string, struct buffer *buf) -{ -	buffer_append_c (buf, '"'); -	for (size_t i = 0; i < string->len; i++) -	{ -		char c = string->value[i]; -		if      (c == '\n')  buffer_append (buf, "\\n", 2); -		else if (c == '\r')  buffer_append (buf, "\\r", 2); -		else if (c == '\t')  buffer_append (buf, "\\t", 2); -		else if (!isprint (c)) -		{ -			char tmp[8]; -			snprintf (tmp, sizeof tmp, "\\x%02x", (unsigned char) c); -			buffer_append (buf, tmp, strlen (tmp)); -		} -		else if (c == '\\')  buffer_append (buf, "\\\\", 2); -		else if (c == '"')   buffer_append (buf, "\\\"", 2); -		else                 buffer_append_c (buf, c); -	} -	buffer_append_c (buf, '"'); -} - -static void -item_to_str (const struct item *item, struct buffer *buf) -{ -	switch (item->type) -	{ -		char *x; -	case ITEM_STRING: -		string_to_str ((struct item_string *) item, buf); -		break; -	case ITEM_WORD: -	{ -		struct item_word *word = (struct item_word *) item; -		buffer_append (buf, word->value, word->len); -		break; -	} -	case ITEM_INTEGER: -		if (!(x = strdup_printf ("%lld", get_integer (item)))) -			goto alloc_failure; -		buffer_append (buf, x, strlen (x)); -		free (x); -		break; -	case ITEM_FLOAT: -		if (!(x = strdup_printf ("%Lf", get_float (item)))) -			goto alloc_failure; -		buffer_append (buf, x, strlen (x)); -		free (x); -		break; -	case ITEM_LIST: -		buffer_append_c (buf, '['); -		item_list_to_str (get_list (item), buf); -		buffer_append_c (buf, ']'); -		break; -	} -	return; - -alloc_failure: -	// This is a bit hackish but it simplifies stuff -	buf->memory_failure = true; -	free (buf->s); -	buf->s = NULL; -} - -static void -item_list_to_str (const struct item *script, struct buffer *buf) -{ -	if (!script) -		return; - -	item_to_str (script, buf); -	while ((script = script->next)) -	{ -		buffer_append_c (buf, ' '); -		item_to_str (script, buf); -	} -} - -// --- IRC protocol ------------------------------------------------------------ - -struct message -{ -	char *prefix;                       ///< Message prefix -	char *command;                      ///< IRC command -	char *params[16];                   ///< Command parameters (0-terminated) -	size_t n_params;                    ///< Number of parameters present -}; - -inline static char * -cut_word (char **s) -{ -	char *start = *s, *end = *s + strcspn (*s, " "); -	*s = end + strspn (end, " "); -	*end = '\0'; -	return start; -} - -static bool -parse_message (char *s, struct message *msg) -{ -	memset (msg, 0, sizeof *msg); - -	// Ignore IRC 3.2 message tags, if present -	if (*s == '@') -	{ -		s += strcspn (s, " "); -		s += strspn (s, " "); -	} - -	// Prefix -	if (*s == ':') -		msg->prefix = cut_word (&s) + 1; - -	// Command -	if (!*(msg->command = cut_word (&s))) -		return false; - -	// Parameters -	while (*s) -	{ -		size_t n = msg->n_params++; -		if (msg->n_params >= N_ELEMENTS (msg->params)) -			return false; -		if (*s == ':') -		{ -			msg->params[n] = ++s; -			break; -		} -		msg->params[n] = cut_word (&s); -	} -	return true; -} - -static struct message * -read_message (void) -{ -	static bool discard = false; -	static char buf[1025]; -	static struct message msg; - -	bool discard_this; -	do -	{ -		if (!fgets (buf, sizeof buf, stdin)) -			return NULL; -		size_t len = strlen (buf); - -		// Just to be on the safe side, if the line overflows our buffer, -		// ignore everything up until the next line. -		discard_this = discard; -		if (len >= 2 && !strcmp (buf + len - 2, "\r\n")) -		{ -			buf[len -= 2] = '\0'; -			discard = false; -		} -		else -			discard = true; -	} -	// Invalid messages are silently ignored -	while (discard_this || !parse_message (buf, &msg)); -	return &msg; -} - -// --- Interfacing with the bot ------------------------------------------------ - -#define BOT_PRINT "ZYKLONB print :script: " - -static const char * -get_config (const char *key) -{ -	printf ("ZYKLONB get_config :%s\r\n", key); -	struct message *msg = read_message (); -	if (!msg || msg->n_params <= 0) -		exit (EXIT_FAILURE); -	return msg->params[0]; -} - -// - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -// TODO: implement more functions; try to avoid writing them in C - -static bool -init_runtime_library_scripts (void) -{ -	bool ok = true; - -	// It's much cheaper (and more fun) to define functions in terms of other -	// ones.  The "unit tests" serve a secondary purpose of showing the usage. -	struct script -	{ -		const char *name;               ///< Name of the function -		const char *definition;         ///< The defining script -		const char *unit_test;          ///< Trivial unit test, must return 1 -	} -	scripts[] = -	{ -		{ "nip",     "swap drop",                    "1 2 nip 2 ="            }, -		{ "over",    "[dup] dip swap",               "1 2 over nip nip 1 ="   }, -		{ "swons",   "swap cons",                    "[2] 1 swons [1 2] ="    }, -		{ "first",   "uncons drop",                  "[1 2 3] first 1 ="      }, -		{ "rest",    "uncons swap drop",             "[1 2 3] rest [2 3] ="   }, -		{ "reverse", "[] swap [swap cons] each",     "[1 2] reverse [2 1] ="  }, -		{ "curry",   "cons",                         "1 2 [+] curry call 3 =" }, - -		{ "xor",     "not swap not + 1 =",           "1 1 xor 0 ="            }, -		{ "min",     "over over < [drop] [nip] if",  "1 2 min 1 ="            }, -		{ "max",     "over over > [drop] [nip] if",  "1 2 max 2 ="            }, - -		{ "all?",    "[and] cat 1 swap fold",        "[3 4 5] [> 3] all? 0 =" }, -		{ "any?",    "[or] cat 0 swap fold",         "[3 4 5] [> 3] any? 1 =" }, - -		{ ">",       "swap <",                       "1 2 > 0 ="              }, -		{ "!=",      "= not",                        "1 2 != 1 ="             }, -		{ "<=",      "> not",                        "1 2 <= 1 ="             }, -		{ ">=",      "< not",                        "1 2 >= 0 ="             }, - -		// XXX: this is a bit crazy and does not work with an empty list -		{ "join",   "[uncons] dip swap [[dup] dip swap [+ +] dip] each drop", -		  "[1 2 3] [>string] map \" -> \" join \"1 -> 2 -> 3\" ="             }, -	}; - -	for (size_t i = 0; i < N_ELEMENTS (scripts); i++) -	{ -		const char *error = NULL; -		struct item *script = parse (scripts[i].definition, &error); -		if (error) -		{ -			printf (BOT_PRINT "error parsing internal script `%s': %s\r\n", -				scripts[i].definition, error); -			ok = false; -		} -		else -			ok &= register_script (scripts[i].name, script); -	} - -	struct context ctx; -	for (size_t i = 0; i < N_ELEMENTS (scripts); i++) -	{ -		const char *error = NULL; -		struct item *script = parse (scripts[i].unit_test, &error); -		if (error) -		{ -			printf (BOT_PRINT "error parsing unit test for `%s': %s\r\n", -				scripts[i].name, error); -			ok = false; -			continue; -		} -		context_init (&ctx); -		execute (&ctx, script); -		item_free_list (script); - -		const char *failure = NULL; -		if (ctx.memory_failure) -			failure = "memory allocation failure"; -		else if (ctx.error) -			failure = ctx.error; -		else if (ctx.stack_size != 1) -			failure = "too many results on the stack"; -		else if (ctx.stack->type != ITEM_INTEGER) -			failure = "result is not an integer"; -		else if (get_integer (ctx.stack) != 1) -			failure = "wrong test result"; -		if (failure) -		{ -			printf (BOT_PRINT "error executing unit test for `%s': %s\r\n", -				scripts[i].name, failure); -			ok = false; -		} -		context_free (&ctx); -	} -	return ok; -} - -static bool -init_runtime_library (void) -{ -	bool ok = true; - -	// Type detection -	ok &= register_handler ("string?",  fn_is_string); -	ok &= register_handler ("word?",    fn_is_word); -	ok &= register_handler ("integer?", fn_is_integer); -	ok &= register_handler ("float?",   fn_is_float); -	ok &= register_handler ("list?",    fn_is_list); - -	// Type conversion -	ok &= register_handler (">string",  fn_to_string); -	ok &= register_handler (">integer", fn_to_integer); -	ok &= register_handler (">float",   fn_to_float); - -	// Miscellaneous -	ok &= register_handler ("length",   fn_length); - -	// Basic stack manipulation -	ok &= register_handler ("dup",      fn_dup); -	ok &= register_handler ("drop",     fn_drop); -	ok &= register_handler ("swap",     fn_swap); - -	// Calling stuff -	ok &= register_handler ("call",     fn_call); -	ok &= register_handler ("dip",      fn_dip); - -	// Control flow -	ok &= register_handler ("if",       fn_if); -	ok &= register_handler ("try",      fn_try); - -	// List processing -	ok &= register_handler ("map",      fn_map); -	ok &= register_handler ("filter",   fn_filter); -	ok &= register_handler ("fold",     fn_fold); -	ok &= register_handler ("each",     fn_each); - -	// List manipulation -	ok &= register_handler ("unit",     fn_unit); -	ok &= register_handler ("cons",     fn_cons); -	ok &= register_handler ("cat",      fn_cat); -	ok &= register_handler ("uncons",   fn_uncons); - -	// Arithmetic operations -	ok &= register_handler ("+",        fn_plus); -	ok &= register_handler ("-",        fn_minus); -	ok &= register_handler ("*",        fn_times); -	ok &= register_handler ("^",        fn_pow); -	ok &= register_handler ("/",        fn_div); -	ok &= register_handler ("%",        fn_mod); - -	// Comparison -	ok &= register_handler ("=",        fn_eq); -	ok &= register_handler ("<",        fn_lt); - -	// Logical operations -	ok &= register_handler ("not",      fn_not); -	ok &= register_handler ("and",      fn_and); -	ok &= register_handler ("or",       fn_or); - -	// Utilities -	ok &= register_handler ("rand",     fn_rand); -	ok &= register_handler ("time",     fn_time); -	ok &= register_handler ("strftime", fn_strftime); - -	ok &= init_runtime_library_scripts (); -	return ok; -} - -static void -free_runtime_library (void) -{ -	struct fn *next, *iter; -	for (iter = g_functions; iter; iter = next) -	{ -		next = iter->next; -		free_function (iter); -	} -} - -// --- Function database ------------------------------------------------------- - -// TODO: a global variable storing the various procedures (db) -// XXX: defining procedures would ideally need some kind of an ACL - -static void -read_db (void) -{ -	// TODO -} - -static void -write_db (void) -{ -	// TODO -} - -// --- Main -------------------------------------------------------------------- - -static char *g_prefix; - -struct user_info -{ -	char *ctx;                          ///< Context: channel or user -	char *ctx_quote;                    ///< Reply quotation -}; - -defn (fn_dot) -{ -	check_stack (1); -	struct item *item = pop (ctx); -	struct user_info *info = ctx->user_data; - -	struct buffer buf = BUFFER_INITIALIZER; -	item_to_str (item, &buf); -	item_free (item); -	buffer_append_c (&buf, '\0'); -	if (buf.memory_failure) -	{ -		ctx->memory_failure = true; -		return false; -	} - -	if (buf.len > 255) -		buf.s[255] = '\0'; - -	printf ("PRIVMSG %s :%s%s\r\n", info->ctx, info->ctx_quote, buf.s); -	free (buf.s); -	return true; -} - -static void -process_message (struct message *msg) -{ -	if (!msg->prefix -	 || strcasecmp (msg->command, "PRIVMSG") -	 || msg->n_params < 2) -		return; -	char *line = msg->params[1]; - -	// Filter out only our commands -	size_t prefix_len = strlen (g_prefix); -	if (strncmp (line, g_prefix, prefix_len)) -		return; -	line += prefix_len; - -	char *command = cut_word (&line); -	if (strcasecmp (command, "script")) -		return; - -	// Retrieve information on how to respond back -	char *msg_ctx = msg->prefix, *x; -	if ((x = strchr (msg_ctx, '!'))) -		*x = '\0'; - -	char *msg_ctx_quote; -	if (strchr ("#+&!", *msg->params[0])) -	{ -		msg_ctx_quote = strdup_printf ("%s: ", msg_ctx); -		msg_ctx = msg->params[0]; -	} -	else -		msg_ctx_quote = strdup (""); - -	if (!msg_ctx_quote) -	{ -		printf (BOT_PRINT "%s\r\n", "memory allocation failure"); -		return; -	} - -	struct user_info info; -	info.ctx = msg_ctx; -	info.ctx_quote = msg_ctx_quote; - -	// Finally parse and execute the macro -	const char *error = NULL; -	struct item *script = parse (line, &error); -	if (error) -	{ -		printf ("PRIVMSG %s :%s%s: %s\r\n", -			msg_ctx, msg_ctx_quote, "parse error", error); -		goto end; -	} - -	struct context ctx; -	context_init (&ctx); -	ctx.user_data = &info; -	execute (&ctx, script); -	item_free_list (script); - -	const char *failure = NULL; -	if (ctx.memory_failure) -		failure = "memory allocation failure"; -	else if (ctx.error) -		failure = ctx.error; -	if (failure) -		printf ("PRIVMSG %s :%s%s: %s\r\n", -			msg_ctx, msg_ctx_quote, "runtime error", failure); -	context_free (&ctx); -end: -	free (msg_ctx_quote); -} - -int -main (int argc, char *argv[]) -{ -	freopen (NULL, "rb", stdin);   setvbuf (stdin,  NULL, _IOLBF, BUFSIZ); -	freopen (NULL, "wb", stdout);  setvbuf (stdout, NULL, _IOLBF, BUFSIZ); - -	struct rlimit limit = -	{ -		.rlim_cur = ADDRESS_SPACE_LIMIT, -		.rlim_max = ADDRESS_SPACE_LIMIT -	}; - -	// Lower the memory limits to something sensible to prevent abuse -	(void) setrlimit (RLIMIT_AS, &limit); - -	read_db (); -	if (!init_runtime_library () -	 || !register_handler (".", fn_dot)) -		printf (BOT_PRINT "%s\r\n", "runtime library initialization failed"); - -	g_prefix = strdup (get_config ("prefix")); -	printf ("ZYKLONB register\r\n"); -	struct message *msg; -	while ((msg = read_message ())) -		process_message (msg); - -	free_runtime_library (); -	free (g_prefix); -	return 0; -} - diff --git a/plugins/zyklonb/seen b/plugins/zyklonb/seen deleted file mode 100755 index 8fc9c82..0000000 --- a/plugins/zyklonb/seen +++ /dev/null @@ -1,160 +0,0 @@ -#!/usr/bin/env lua --- --- ZyklonB seen plugin --- --- Copyright 2016 Přemysl Eric Janouch <p@janouch.name> --- See the file LICENSE for licensing information. --- - -function parse (line) -	local msg = { params = {} } -	line = line:match ("[^\r]*") -	for start, word in line:gmatch ("()([^ ]+)") do -		local colon = word:match ("^:(.*)") -		if start == 1 and colon then -			msg.prefix = colon -		elseif not msg.command then -			msg.command = word -		elseif colon then -			table.insert (msg.params, line:sub (start + 1)) -			break -		elseif start ~= #line then -			table.insert (msg.params, word) -		end -	end -	return msg -end - -function get_config (name) -	io.write ("ZYKLONB get_config :", name, "\r\n") -	return parse (io.read ()).params[1] -end - --- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -io.output ():setvbuf ('line') -local prefix = get_config ('prefix') -io.write ("ZYKLONB register\r\n") - -local db = {} -local db_filename = "seen.db" -local db_garbage = 0 - -function remember (who, where, when, what) -	if not db[who] then db[who] = {} end -	if db[who][where] then db_garbage = db_garbage + 1 end -	db[who][where] = { tonumber (when), what } -end - --- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -local db_file, e = io.open (db_filename, "a+") -if not db_file then error ("cannot open database: " .. e, 0) end - -function db_store (who, where, when, what) -	db_file:write (string.format -		(":%s %s %s %s :%s\n", who, "PRIVMSG", where, when, what)) -end - -function db_compact () -	db_file:close () - -	-- Unfortunately, default Lua doesn't have anything like mkstemp() -	local db_tmpname = db_filename .. "." .. os.time () -	db_file, e = io.open (db_tmpname, "a+") -	if not db_file then error ("cannot save database: " .. e, 0) end - -	for who, places in pairs (db) do -		for where, data in pairs (places) do -			db_store (who, where, data[1], data[2]) -		end -	end -	db_file:flush () - -	local ok, e = os.rename (db_tmpname, db_filename) -	if not ok then error ("cannot save database: " .. e, 0) end -	db_garbage = 0 -end - -for line in db_file:lines () do -	local msg = parse (line) -	remember (msg.prefix, table.unpack (msg.params)) -end - --- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -function seen (who, where, args) -	local respond = function (...) -		local privmsg = function (target, ...) -			io.write ("PRIVMSG ", target, " :", table.concat { ... }, "\r\n") -		end -		if where:match ("^[#&!+]") then -			privmsg (where, who, ": ", ...) -		else -			privmsg (who, ...) -		end -	end - -	local whom, e, garbage = args:match ("^(%S+)()%s*(.*)") -	if not whom or #garbage ~= 0 then -		return respond ("usage: <name>") -	elseif who:lower () == whom:lower () then -		return respond ("I can see you right now.") -	end - -	local top = {} -	-- That is, * acts like a wildcard, otherwise everything is escaped -	local pattern = "^" .. whom:gsub ("[%^%$%(%)%%%.%[%]%+%-%?]", "%%%0") -		:gsub ("%*", ".*"):lower () .. "$" -	for name, places in pairs (db) do -		if places[where] and name:lower ():match (pattern) then -			local when, what = table.unpack (places[where]) -			table.insert (top, { name = name, when = when, what = what }) -		end -	end -	if #top == 0 then -		return respond ("I have not seen \x02" .. whom .. "\x02 here.") -	end - -	-- Get all matching nicknames ordered from the most recently active -	-- and make the list case insensitive (remove older duplicates) -	table.sort (top, function (a, b) return a.when > b.when end) -	for i = #top, 2, -1 do -		if top[i - 1].name:lower () == top[i].name:lower () then -			table.remove (top, i) -		end -	end - -	-- Hopefully the formatting mess will disrupt highlights in clients -	for i = 1, math.min (#top, 3) do -		local name = top[i].name:gsub ("^.", "%0\x02\x02") -		respond (string.format ("\x02%s\x02 -> %s -> %s", -			name, os.date ("%c", top[i].when), top[i].what)) -	end -end - -function handle (msg) -	local who = msg.prefix:match ("^[^!@]*") -	local where, what = table.unpack (msg.params) -	local when = os.time () - -	local what_log = what:gsub ("^\x01ACTION", "*"):gsub ("\x01$", "") -	remember (who, where, when, what_log) -	db_store (who, where, when, what_log) - -	-- Comment out to reduce both disk load and reliability -	db_file:flush () - -	if db_garbage > 5000 then db_compact () end - -	if what:sub (1, #prefix) == prefix then -		local command = what:sub (#prefix + 1) -		local name, e = command:match ("^(%S+)%s*()") -		if name == 'seen' then seen (who, where, command:sub (e)) end -	end -end - -for line in io.lines () do -	local msg = parse (line) -	if msg.command == "PRIVMSG" then handle (msg) end -end diff --git a/plugins/zyklonb/seen-import-degesch.pl b/plugins/zyklonb/seen-import-degesch.pl deleted file mode 100755 index ddef6be..0000000 --- a/plugins/zyklonb/seen-import-degesch.pl +++ /dev/null @@ -1,39 +0,0 @@ -#!/usr/bin/env perl -# Creates a database for the "seen" plugin from logs for degesch. -# The results may not be completely accurate but are good for jumpstarting. -# Usage: ./seen-import-degesch.pl LOG-FILE... > seen.db - -use strict; -use warnings; -use File::Basename; -use Time::Piece; - -my $db = {}; -for (@ARGV) { -	my $where = (basename($_) =~ /\.(.*).log/)[0]; -	unless ($where) { -		print STDERR "Invalid filename: $_\n"; -		next; -	} - -	open my $fh, '<', $_ or die "Failed to open log file: $!"; -	while (<$fh>) { -		my ($when, $who, $who_action, $what) = -			/^(.{19}) (?:<[~&@%+]*(.*?)>| \*  (\S+)) (.*)/; -		next unless $when; - -		if ($who_action) { -			$who = $who_action; -			$what = "* $what"; -		} -		$db->{$who}->{$where} = -			[Time::Piece->strptime($when, "%Y-%m-%d %T")->epoch, $what]; -	} -} - -while (my ($who, $places) = each %$db) { -	while (my ($where, $data) = each %$places) { -		my ($when, $what) = @$data; -		print ":$who PRIVMSG $where $when :$what\n"; -	} -} diff --git a/plugins/zyklonb/youtube b/plugins/zyklonb/youtube deleted file mode 100755 index 53b86d8..0000000 --- a/plugins/zyklonb/youtube +++ /dev/null @@ -1,111 +0,0 @@ -#!/usr/bin/env python3 -# -# ZyklonB YouTube plugin, displaying info about YouTube links -# -# Copyright 2014 - 2015, Přemysl Eric Janouch <p@janouch.name> -# See the file LICENSE for licensing information. -# - -import sys -import io -import re -import json -import urllib.request - -class Plugin: -	re_msg = re.compile ('(?::([^! ]*)(?:!([^@]*)@([^ ]*))? +)?' -		'([^ ]+)(?: +(.*))?\r\n$') -	re_args = re.compile (':?((?<=:).*|[^ ]+) *') - -	def parse (self, line): -		m = self.re_msg.match (line) -		if m is None: -			return None - -		(nick, user, host, command, args) = m.groups () -		args = [] if args is None else self.re_args.findall (args) -		return (nick, user, host, command, args) - -	def get_config (self, key): -		print ("ZYKLONB get_config :%s" % key) -		(_, _, _, _, args) = self.parse (sys.stdin.readline ()) -		return args[0] - -	def bot_print (self, what): -		print ('ZYKLONB print :%s' % what) - -class YouTube (Plugin): -	re_videos = [re.compile (x) for x in [ -		r'youtube\.[a-z]+/[^ ]*[&?]v=([-\w]+)', -		r'youtube\.[a-z]+/v/([-\w]+)', -		r'youtu\.be/([-\w]+)' -	]] -	re_playlists = [re.compile (x) for x in [ -		r'youtube\.[a-z]+/playlist[&?][^ ]*(?<=&|\?)list=([-\w]+)', -	]] - -	def print_info (self, channel, url, cb): -		try: -			data = json.loads (urllib.request.urlopen -				(url, None, 30).read ().decode ('utf-8')) - -			for line in map (lambda x: "YouTube: " + cb (x), data['items']): -				print ("PRIVMSG %s :%s" % (channel, -					line.encode ('utf-8').decode ('iso8859-1'))) - -		except Exception as err: -			self.bot_print ('youtube: %s' % (err)) - -	def print_video_info (self, channel, video_id): -		url = 'https://www.googleapis.com/youtube/v3/' \ -			+ 'videos?id=%s&key=%s&part=snippet,contentDetails,statistics' \ -			% (video_id, self.youtube_api_key) -		self.print_info (channel, url, lambda x: "%s | %s | %sx" % ( -			x['snippet']['title'], -			x['contentDetails']['duration'][2:].lower (), -			x['statistics']['viewCount'])) - -	def print_playlist_info (self, channel, playlist_id): -		url = 'https://www.googleapis.com/youtube/v3/' \ -			+ 'playlists?id=%s&key=%s&part=snippet,contentDetails' \ -			% (playlist_id, self.youtube_api_key) -		self.print_info (channel, url, lambda x: "%s | %d videos" % ( -			x['snippet']['title'], -			x['contentDetails']['itemCount'])) - -	def process_line (self, line): -		msg = self.parse (line) -		if msg is None: -			return - -		(nick, user, host, command, args) = msg -		if command != 'PRIVMSG' or len (args) < 2: -			return - -		ctx = args[0] -		if not ctx.startswith (('#', '+', '&', '!')): -			ctx = nick - -		for regex in self.re_videos: -			for i in regex.findall (args[1]): -				self.print_video_info (ctx, i) -		for regex in self.re_playlists: -			for i in regex.findall (args[1]): -				self.print_playlist_info (ctx, i) - -	def run (self): -		self.youtube_api_key = self.get_config ('youtube_api_key') -		if self.youtube_api_key == "": -			self.bot_print ("youtube: missing `youtube_api_key'") - -		print ("ZYKLONB register") - -		for line in sys.stdin: -			self.process_line (line) - -sys.stdin = io.TextIOWrapper (sys.__stdin__.buffer, -	encoding = 'iso8859-1', newline = '\r\n', line_buffering = True) -sys.stdout = io.TextIOWrapper (sys.__stdout__.buffer, -	encoding = 'iso8859-1', newline = '\r\n', line_buffering = True) - -YouTube ().run ()  | 
