view utillib.tcl @ 428:04021e2e26c3

utillib: Fix silly bugs.
author Matti Hamalainen <ccr@tnsp.org>
date Sun, 08 Jan 2017 04:15:50 +0200
parents 84d3d7abeb8a
children 124b97f5a19d
line wrap: on
line source

##########################################################################
#
# 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 "&#45;|-|&#39;|'|—|-|&rlm;||&#8212;|-|&#8211;|--|&#x202a;||&#x202c;|"
append utl_html_ent_str "|&lrm;||&aring;|å|&Aring;|Å|&eacute;|é|&#58;|:|&nbsp;| "
append utl_html_ent_str "|&#8221;|\"|&#8220;|\"|&laquo;|<<|&raquo;|>>|&quot;|\""
append utl_html_ent_str "|&auml;|ä|&ouml;|ö|&Auml;|Ä|&Ouml;|Ö|&amp;|&|&lt;|<|&gt;|>"
append utl_html_ent_str "|&#228;|ä|&#229;|ö|&mdash;|-|&#039;|'|&ndash;|-|&#034;|\""
append utl_html_ent_str "|&#124;|-|&#8217;|'|&uuml;|ü|&Uuml;|Ü|&bull;|*|&euro;|€"
append utl_html_ent_str "|&rdquo;|\"|&#8216;|'|&#xe4;|ä|&#xb7;|*|&#174;|®|&acute;|'"
append utl_html_ent_str "|&#246;|ö|&#xf6;|ö|&#35;|#|&apos;|'|&shy;||–|-|”|\""
append utl_html_ent_str "|&#x2026;|...|&hellip;|...|&#34;|\"|&#xad;||&#064;|#"
append utl_html_ent_str "|&#xa0;| "
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 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 utl_match_delim_list {ulist ustr} {
  foreach ukey [split $ulist ";"] {
    if {[string match $ukey $ustr]} {
      return 1
    }
  }
  return 0
}


proc utl_msg_do {upreferredmsg upublic unick uchan umsg} {
  foreach uline [utl_str_split $umsg 450] {
    if {$upublic == 1} {
      putserv "$upreferredmsg $uchan :$uline"
    } else {
      putserv "$upreferredmsg $unick :$uline"
    }
  }
}


proc utl_ctime {utime} {
  if {$utime == "" || $utime == "*"} {
    set utime 0
  }
  return [clock format $utime -format "%d.%m.%Y %H:%M"]
}


###
### 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 {set udb_handle [tdbc::sqlite3::connection new $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 {set udb_handle [tdbc::postgres::connection new {*}$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 {set udb_handle [tdbc::mysql::connection new {*}$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
  }
  return 1
}


proc utl_escape {str} {
  return [string map {' ''} $str]
}


###
### Functions for certain scripts
###
proc utl_confirm_yesno { uprompt } {
  puts -nonewline "$uprompt \[y/N\]? "
  flush stdout
  set response [gets stdin]
  if {[string tolower $response] == "y"} {
    return 1
  } else {
    return 0
  }
}


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 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."
    return 0
  }
  return 1
}


proc utl_create_table_or_fail { dbh utable usql } {
  if {![utl_create_table $dbh $utable $usql]} {
    exit 3
  }
}