Mercurial > hg > egg-tcls
changeset 290:cad1041b5bc4
Revamp the utility functions library.
| author | Matti Hamalainen <ccr@tnsp.org> |
|---|---|
| date | Mon, 26 Jan 2015 14:00:21 +0200 |
| parents | 5067843cee3d |
| children | 54d34d086b47 |
| files | utillib.tcl |
| diffstat | 1 files changed, 122 insertions(+), 46 deletions(-) [+] |
line wrap: on
line diff
--- a/utillib.tcl Sun Jan 25 15:34:50 2015 +0200 +++ b/utillib.tcl Mon Jan 26 14:00:21 2015 +0200 @@ -1,14 +1,124 @@ -### Helper functions -proc escape { str } { - return [string map {' ''} $str] +########################################################################## +# +# TCL functions library by Matti 'ccr' Hamalainen <ccr@tnsp.org> +# (C) Copyright 2015 Tecnic Software productions (TNSP) +# +# This script is freely distributable under GNU GPL (version 2) license. +# +########################################################################## + +set utl_html_ent_str "-|-|'|'|—|-|‏||—|-|–|--|‪||‬|" +append utl_html_ent_str "|‎||å|å|Å|Å|é|é|:|:| | " +append utl_html_ent_str "|”|\"|“|\"|«|<<|»|>>|"|\"" +append utl_html_ent_str "|ä|ä|ö|ö|Ä|Ä|Ö|Ö|&|&|<|<|>|>" +append utl_html_ent_str "|ä|ä|å|ö|—|-|'|'|–|-|"|\"" +append utl_html_ent_str "|||-|’|'|ü|ü|Ü|Ü|•|*|€|€" +append utl_html_ent_str "|”|\"|‘|'" +set utl_html_ent_list [split [encoding convertfrom "utf-8" $utl_html_ent_str] "|"] + + +proc utl_convert_html_ent {udata} { + global utl_html_ent_list + return [string map -nocase $utl_html_ent_list [string map $utl_html_ent_list $udata]] } -proc lescape { lst pos } { - return [escape [lindex $lst $pos]] + +proc utl_str_split {str maxlen} { + set pos 0 + set len [string length $str] + set ulen 0 + set ustr "" + set result {} + while {$pos < $len} { + set end [string wordend $str $pos] + set new [expr $end - $pos + 1] + if {$ulen + $new < $maxlen} { + append ustr [string range $str $pos $end] + set ulen [expr $ulen + $new] + } else { + append ustr [string range $str $pos $end] + lappend result $ustr + set ustr "" + set ulen 0 + } + set pos [expr $end + 1] + } + if {$ustr != ""} { + lappend result $ustr + } + return $result } -proc confirm_yesno { uprompt } { +### +### SQL database handling +### +proc utl_tdbc_sql_init {ndb_handle db_type db_name db_host db_port db_user db_pass} { + upvar $ndb_handle udb_handle + + if {$db_type == "sqlite"} { + if {$db_name == ""} { + putlog " SQLite3 database file not set." + return 0 + } + if {![file exists $db_name]} { + putlog " URLLog SQLite3 database file '$db_name' not found, or not accessible!" + return 0 + } + package require tdbc::sqlite3 1.0 + if {[catch {tdbc::sqlite3::connection create db_handle $db_name} db_errmsg]} { + putlog " Could not open SQLite3 database '$db_name': $db_errmsg" + return 0 + } + putlog " (Using SQLite3 database $db_name)" + } elseif {$db_type == "postgres" || $db_type == "mysql"} { + # Check parameters + set db_args {} + if {$db_user != ""} { lappend db_args -user $db_user } + if {$db_pass != ""} { lappend db_args -passwd $db_pass } + if {$db_host != ""} { + lappend db_args -host $db_pass + if {$db_posrt != 0} { + lappend db_args -port $db_port + set db_host "${db_host}:${db_port}" + } + } else { + set db_host "localhost" + } + if {$db_name == ""} { + putlog " Database name not set." + return 0 + } + lappend db_args -database $db_name + + if {$db_type == "postgres"} { + package require tdbc::postgres 1.0 + if {[catch {tdbc::postgres::connection create db_handle {*}$db_args} db_errmsg]} { + putlog " Could not connect to PostgreSQL database '$db_name @ $db_host': $db_errmsg" + return 0 + } + putlog " (Using PostgreSQL database $db_name @ $db_host)" + } elseif {$db_type == "mysql"} { + package require tdbc::mysql 1.0 + if {[catch {tdbc::mysql::connection create db_handle {*}$db_args} db_errmsg]} { + putlog " Could not connect to MySQL database '$db_name @ $db_host': $db_errmsg" + return 0 + } + putlog " (Using MySQL database $db_name @ $db_host)" + } + } else { + putlog " Invalid or unsupported database type: '$db_type'." + return 0 + } + set udb_handle db_handle + return 1 +} + + +### +### Functions for certain scripts +### +proc utl_confirm_yesno { uprompt } { puts -nonewline "$uprompt \[y/N\]? " flush stdout set response [gets stdin] @@ -19,24 +129,16 @@ } } -proc open_db { dbfile } { - global dbh - if {[catch {sqlite3 dbh $dbfile} uerrmsg]} { - puts "Could not open SQLite3 database '$dbfile': $uerrmsg." - exit 2 - } -} -proc drop_table { utable } { - global dbh +proc utl_drop_table { dbh utable } { puts "Dropping current table '$utable'." if {[catch {dbh eval "DROP TABLE $utable"} uerrmsg]} { puts "Dropping table resulted in error (ignored): $uerrmsg." } } -proc create_table { utable usql } { - global dbh + +proc utl_create_table { dbh utable usql } { puts "Creating new table '$utable'." if {[catch {dbh eval "CREATE TABLE $utable ($usql)"} uerrmsg]} { puts "Error creating table: $uerrmsg." @@ -45,35 +147,9 @@ return 1 } -proc create_table_or_fail { utable usql } { - if {![create_table $utable $usql]} { + +proc utl_create_table_or_fail { dbh utable usql } { + if {![utl_create_table $dbh $utable $usql]} { exit 3 } } - -proc create_table_urls { } { - create_table_or_fail "urls" "id INTEGER PRIMARY KEY AUTOINCREMENT, utime INT, url VARCHAR(2048), user VARCHAR(32), host VARCHAR(256), chan VARCHAR(32), title VARCHAR(256)" -} - -proc create_table_quotes_votes { utable ufail } { - - set sql1 "id INTEGER PRIMARY KEY AUTOINCREMENT, utime INT, utext VARCHAR(2048), user VARCHAR(32), host VARCHAR(256), chan VARCHAR(32)" - set sql2 "id INTEGER PRIMARY KEY AUTOINCREMENT, user VARCHAR(32), urlid INTEGER, vote INTEGER" - - if {$ufail} { - create_table_or_fail "$utable" "$sql1" - create_table_or_fail "${utable}_votes" "$sql2" - } else { - create_table "$utable" "$sql1" - create_table "${utable}_votes" "$sql2" - } -} - - -proc drop_table_feeds { } { - drop_table "feeds" -} - -proc create_table_feeds { } { - create_table_or_fail "feeds" "feed VARCHAR(64), utime INT, url VARCHAR(512), title VARCHAR(256)" -}