Bureautique.tcl
No OneTemporary
Actions

Size

4 KB

Referenced Files

None

Subscribers

None

Bureautique.tcl
View Options

	bind dcc - antidater dcc:antidater
	bind dcc - postdater dcc:postdater
	bind dcc - days dcc:days
	bind dcc - quux dcc:quux
	bind dcc - paypal dcc:paypal

	#
	# Dates calculation
	#

	#Removes $days from $date or if unspecified, current unixtime
	proc antidater {days {date ""}} {
	postdater [expr $days * -1] $date
	}

	#Adds $days from $date or if unspecified, current unixtime
	proc postdater {days {date ""}} {
	if {$date == ""} {
	set date [unixtime]
	}
	incr date [expr 86400 * $days]
	}

	#.antidater 15
	#.antidater 2011-01-29 4
	proc dcc:antidater {handle idx arg} {
	set argc [llength $arg]
	if {$argc == 0} {
	putdcc $idx "De combien de jours dois-je antidater ?"
	return
	}
	if {$argc == 1} {
	set date ""
	set days $arg
	} {
	if [catch {set date [clock scan [lindex $arg 0]]} err] {
	putdcc $idx $err
	return
	}
	set days [lindex $arg 1]
	}
	if ![isnumber $days] {
	putdcc $idx "$days n'est pas un nombre de jours"
	return
	}
	putdcc $idx [clock format [antidater $days $date] -format "%Y-%m-%d"]
	return 1
	}

	#.postdater 15
	#.postdater 2011-01-29 4
	proc dcc:postdater {handle idx arg} {
	set argc [llength $arg]
	if {$argc == 0} {
	putdcc $idx "De combien de jours dois-je postdater ?"
	return
	}
	if {$argc == 1} {
	set date ""
	set days $arg
	} {
	if [catch {set date [clock scan [lindex $arg 0]]} err] {
	putdcc $idx $err
	return
	}
	set days [lindex $arg 1]
	}
	if ![isnumber $days] {
	putdcc $idx "$days n'est pas un nombre de jours"
	return
	}
	putdcc $idx [clock format [postdater $days $date] -format "%Y-%m-%d"]
	return 1
	}

	namespace eval ::quux:: {
	## Adds a quux
	##
	## @param $userid The user id
	## @param $category The quux category
	## @param $content The quux content
	## @param $tags The quux tags [optional]
	proc add {userid category content {tags ""}} {
	global username
	lappend tags client:$username
	sqladd quux "user_id quux_date quux_category quux_content quux_tags" [list $userid [unixtime] $category $content $tags]
	sqllastinsertid
	}

	## Tags a quux
	##
	## @param $id The quux id
	## @param $tags The tags to add
	proc tag {id tags} {
	if {![isnumber $id]} { error "bad id \"$id\": must be integer" }
	switch [sql "SELECT LENGTH(quux_tags) FROM quux WHERE quux_id = $id"] {
	"" { error "Not existing quux: $id" }
	0 { set value '[sqlescape $tags]' }
	default { set value "CONCAT(quux_tags, ' ', '[sqlescape $tags]')" }
	}
	sql "UPDATE quux SET quux_tags = $value WHERE quux_id = $id"
	}

	## Determines if the specified user is the quux's owner
	##
	## @param $id The quux id
	## @param $userid The user id
	## @return 1 if the quux exists and added by the specified user; otherwise, 0
	proc isauthor {id userid} {
	if {![isnumber $id]} { error "bad id \"$id\": must be integer" }
	if {![isnumber $userid]} { error "bad userid \"$userid\": must be integer" }
	sql "SELECT count(*) FROM quux WHERE quux_id = $id AND user_id = $userid"
	}
	}

	proc dcc:quux {handle idx arg} {
	#.quux
	if {[llength $arg] == 0} {
	#Prints categories
	putdcc $idx [sql "SELECT DISTINCT quux_category FROM quux WHERE user_id = [getuserid $idx] AND quux_deleted = 0"]
	return 1
	}

	#.quux <command>
	set command [lindex $arg 0]
	switch $command {
	"tag" {
	#.quux tag <quux id> <tag to add>

	set id [lindex $arg 1]
	set content [string range $arg [string length $id]+5 end]

	if {![isnumber $id]} {
	putdcc $idx "Not a number."
	} elseif {![quux::isauthor $id [getuserid $idx]]} {
	putdcc $idx "Not your quux."
	} {
	quux::tag $id $content
	putcmdlog "#$handle# quux tag ..."
	}
	return 0
	}
	}

	#.quux <category>
	if {[llength $arg] == 1} {
	global username
	set category $arg
	set i 0
	set dateformat [registry get date.formats.long]
	set sql "SELECT quux_id, quux_date, quux_category, quux_content, quux_tags FROM quux WHERE user_id = [getuserid $idx] AND quux_deleted = 0"
	if { $category != "*" } { append sql " AND quux_category = '[sqlescape $category]'" }
	append sql " ORDER BY quux_date DESC LIMIT 20"
	foreach row [sql $sql] {
	foreach "id date cat content tags" $row {}
	set text "[completestringright $id 3]. "
	if { $category == "*" } { append text "$cat - " }
	append text $content

	#Tags
	set tags [string trim [string map [list "client:$username" ""] $tags]]
	if {$tags != ""} {
	append text " \00314$tags\003"
	}

	putdcc $idx $text
	incr i
	}
	if {$i == 0} {
	putdcc $idx "$arg xuuQ."
	return 0
	}
	return 1
	}

	#.quux <category> <text to add>
	set category [lindex $arg 0]
	set content [string range $arg [string length $category]+1 end]
	putdcc $idx "Published under QX[quux::add [getuserid $idx] $category $content]"
	putcmdlog "#$handle# quux ..."
	return 0
	}

	#
	# Paypal calculation
	#

	namespace eval ::paypal {
	# -rate% - 0.35 €
	# Default rate: 3.4% for EU
	proc gross2net {net {rate 3.4}} {
	format %0.2f [expr ($net - 0.35) / (100 + $rate) * 100]
	}

	# +rate% + 0.35 €
	proc net2gross {gross {rate 3.4}} {
	format %0.2f [expr $gross * (100 + $rate) / 100 + 0.35]
	}
	}

File Metadata

Mime Type: text/plain
Expires: Tue, Jul 29, 14:21 (1 d, 6 h)
Storage Engine: blob
Storage Format: Raw Data
Storage Handle: 2838451
Default Alt Text: Bureautique.tcl (4 KB)

Bureautique.tclNo OneTemporaryActions

Bureautique.tclView Options

File Metadata

Event Timeline

Bureautique.tcl
No OneTemporary
Actions

Bureautique.tcl
View Options