sqlitecon.tcl

sqlite-3.4.1,嵌入式数据库.是一个功能强大的开源数据库,给学习和研发以及小型公司的发展带来了全所未有的好处.

# A Tk console widget for SQLite.  Invoke sqlitecon::create with a window name,
# a prompt string, a title to set a new top-level window, and the SQLite
# database handle.  For example:
#
#     sqlitecon::create .sqlcon {sql:- } {SQL Console} db
#
# A toplevel window is created that allows you to type in SQL commands to
# be processed on the spot.
#
# A limited set of dot-commands are supported:
#
#     .table
#     .schema ?TABLE?
#     .mode list|column|multicolumn|line
#     .exit
#
# In addition, a new SQL function named "edit()" is created.  This function
# takes a single text argument and returns a text result.  Whenever the
# the function is called, it pops up a new toplevel window containing a
# text editor screen initialized to the argument.  When the "OK" button
# is pressed, whatever revised text is in the text editor is returned as
# the result of the edit() function.  This allows text fields of SQL tables
# to be edited quickly and easily as follows:
#
#    UPDATE table1 SET dscr = edit(dscr) WHERE rowid=15;
#


# Create a namespace to work in
#
namespace eval ::sqlitecon {
  # do nothing
}

# Create a console widget named $w.  The prompt string is $prompt.
# The title at the top of the window is $title.  The database connection
# object is $db
#
proc sqlitecon::create {w prompt title db} {
  upvar #0 $w.t v
  if {[winfo exists $w]} {destroy $w}
  if {[info exists v]} {unset v}
  toplevel $w
  wm title $w $title
  wm iconname $w $title
  frame $w.mb -bd 2 -relief raised
  pack $w.mb -side top -fill x
  menubutton $w.mb.file -text File -menu $w.mb.file.m
  menubutton $w.mb.edit -text Edit -menu $w.mb.edit.m
  pack $w.mb.file $w.mb.edit -side left -padx 8 -pady 1
  set m [menu $w.mb.file.m -tearoff 0]
  $m add command -label {Close} -command "destroy $w"
  sqlitecon::create_child $w $prompt $w.mb.edit.m
  set v(db) $db
  $db function edit ::sqlitecon::_edit
}

# This routine creates a console as a child window within a larger
# window.  It also creates an edit menu named "$editmenu" if $editmenu!="".
# The calling function is responsible for posting the edit menu.
#
proc sqlitecon::create_child {w prompt editmenu} {
  upvar #0 $w.t v
  if {$editmenu!=""} {
    set m [menu $editmenu -tearoff 0]
    $m add command -label Cut -command "sqlitecon::Cut $w.t"
    $m add command -label Copy -command "sqlitecon::Copy $w.t"
    $m add command -label Paste -command "sqlitecon::Paste $w.t"
    $m add command -label {Clear Screen} -command "sqlitecon::Clear $w.t"
    $m add separator
    $m add command -label {Save As...} -command "sqlitecon::SaveFile $w.t"
    catch {$editmenu config -postcommand "sqlitecon::EnableEditMenu $w"}
  }
  scrollbar $w.sb -orient vertical -command "$w.t yview"
  pack $w.sb -side right -fill y
  text $w.t -font fixed -yscrollcommand "$w.sb set"
  pack $w.t -side right -fill both -expand 1
  bindtags $w.t Sqlitecon
  set v(editmenu) $editmenu
  set v(history) 0
  set v(historycnt) 0
  set v(current) -1
  set v(prompt) $prompt
  set v(prior) {}
  set v(plength) [string length $v(prompt)]
  set v(x) 0
  set v(y) 0
  set v(mode) column
  set v(header) on
  $w.t mark set insert end
  $w.t tag config ok -foreground blue
  $w.t tag config err -foreground red
  $w.t insert end $v(prompt)
  $w.t mark set out 1.0
  after idle "focus $w.t"
}

bind Sqlitecon <1> {sqlitecon::Button1 %W %x %y}
bind Sqlitecon <B1-Motion> {sqlitecon::B1Motion %W %x %y}
bind Sqlitecon <B1-Leave> {sqlitecon::B1Leave %W %x %y}
bind Sqlitecon <B1-Enter> {sqlitecon::cancelMotor %W}
bind Sqlitecon <ButtonRelease-1> {sqlitecon::cancelMotor %W}
bind Sqlitecon <KeyPress> {sqlitecon::Insert %W %A}
bind Sqlitecon <Left> {sqlitecon::Left %W}
bind Sqlitecon <Control-b> {sqlitecon::Left %W}
bind Sqlitecon <Right> {sqlitecon::Right %W}
bind Sqlitecon <Control-f> {sqlitecon::Right %W}
bind Sqlitecon <BackSpace> {sqlitecon::Backspace %W}
bind Sqlitecon <Control-h> {sqlitecon::Backspace %W}
bind Sqlitecon <Delete> {sqlitecon::Delete %W}
bind Sqlitecon <Control-d> {sqlitecon::Delete %W}
bind Sqlitecon <Home> {sqlitecon::Home %W}
bind Sqlitecon <Control-a> {sqlitecon::Home %W}
bind Sqlitecon <End> {sqlitecon::End %W}
bind Sqlitecon <Control-e> {sqlitecon::End %W}
bind Sqlitecon <Return> {sqlitecon::Enter %W}
bind Sqlitecon <KP_Enter> {sqlitecon::Enter %W}
bind Sqlitecon <Up> {sqlitecon::Prior %W}
bind Sqlitecon <Control-p> {sqlitecon::Prior %W}
bind Sqlitecon <Down> {sqlitecon::Next %W}
bind Sqlitecon <Control-n> {sqlitecon::Next %W}
bind Sqlitecon <Control-k> {sqlitecon::EraseEOL %W}
bind Sqlitecon <<Cut>> {sqlitecon::Cut %W}
bind Sqlitecon <<Copy>> {sqlitecon::Copy %W}
bind Sqlitecon <<Paste>> {sqlitecon::Paste %W}
bind Sqlitecon <<Clear>> {sqlitecon::Clear %W}

# Insert a single character at the insertion cursor
#
proc sqlitecon::Insert {w a} {
  $w insert insert $a
  $w yview insert
}

# Move the cursor one character to the left
#
proc sqlitecon::Left {w} {
  upvar #0 $w v
  scan [$w index insert] %d.%d row col
  if {$col>$v(plength)} {
    $w mark set insert "insert -1c"
  }
}

# Erase the character to the left of the cursor
#
proc sqlitecon::Backspace {w} {
  upvar #0 $w v
  scan [$w index insert] %d.%d row col
  if {$col>$v(plength)} {
    $w delete {insert -1c}
  }
}

# Erase to the end of the line
#
proc sqlitecon::EraseEOL {w} {
  upvar #0 $w v
  scan [$w index insert] %d.%d row col
  if {$col>=$v(plength)} {
    $w delete insert {insert lineend}
  }
}

# Move the cursor one character to the right
#
proc sqlitecon::Right {w} {
  $w mark set insert "insert +1c"
}

# Erase the character to the right of the cursor
#
proc sqlitecon::Delete w {
  $w delete insert
}

# Move the cursor to the beginning of the current line
#
proc sqlitecon::Home w {
  upvar #0 $w v
  scan [$w index insert] %d.%d row col
  $w mark set insert $row.$v(plength)
}

# Move the cursor to the end of the current line
#
proc sqlitecon::End w {
  $w mark set insert {insert lineend}
}

# Add a line to the history
#
proc sqlitecon::addHistory {w line} {
  upvar #0 $w v
  if {$v(historycnt)>0} {
    set last [lindex $v(history) [expr $v(historycnt)-1]]
    if {[string compare $last $line]} {
      lappend v(history) $line
      incr v(historycnt)
    }
  } else {
    set v(history) [list $line]
    set v(historycnt) 1
  }
  set v(current) $v(historycnt)
}

# Called when "Enter" is pressed.  Do something with the line
# of text that was entered.
#
proc sqlitecon::Enter w {
  upvar #0 $w v
  scan [$w index insert] %d.%d row col
  set start $row.$v(plength)
  set line [$w get $start "$start lineend"]
  $w insert end \n
  $w mark set out end
  if {$v(prior)==""} {
    set cmd $line
  } else {
    set cmd $v(prior)\n$line
  }
  if {[string index $cmd 0]=="." || [$v(db) complete $cmd]} {
    regsub -all {\n} [string trim $cmd] { } cmd2
    addHistory $w $cmd2
    set rc [catch {DoCommand $w $cmd} res]
    if {![winfo exists $w]} return
    if {$rc} {
      $w insert end $res\n err
    } elseif {[string length $res]>0} {
      $w insert end $res\n ok
    }
    set v(prior) {}
    $w insert end $v(prompt)
  } else {
    set v(prior) $cmd
    regsub -all {[^ ]} $v(prompt) . x
    $w insert end $x
  }
  $w mark set insert end
  $w mark set out {insert linestart}
  $w yview insert
}

# Execute a single SQL command.  Pay special attention to control
# directives that begin with "."
#
# The return value is the text output from the command, properly
# formatted.
#
proc sqlitecon::DoCommand {w cmd} {
  upvar #0 $w v
  set mode $v(mode)
  set header $v(header)
  if {[regexp {^(\.[a-z]+)} $cmd all word]} {
    if {$word==".mode"} {
      regexp {^.[a-z]+ +([a-z]+)} $cmd all v(mode)
      return {}
    } elseif {$word==".exit"} {
      destroy [winfo toplevel $w]
      return {}
    } elseif {$word==".header"} {
      regexp {^.[a-z]+ +([a-z]+)} $cmd all v(header)
      return {}
    } elseif {$word==".tables"} {
      set mode multicolumn
      set cmd {SELECT name FROM sqlite_master WHERE type='table'
               UNION ALL
               SELECT name FROM sqlite_temp_master WHERE type='table'}
      $v(db) eval {PRAGMA database_list} {
         if {$name!="temp" && $name!="main"} {
            append cmd "UNION ALL SELECT name FROM $name.sqlite_master\
                        WHERE type='table'"
         }
      }
      append cmd  { ORDER BY 1}
    } elseif {$word==".fullschema"} {
      set pattern %
      regexp {^.[a-z]+ +([^ ]+)} $cmd all pattern
      set mode list
      set header 0
      set cmd "SELECT sql FROM sqlite_master WHERE tbl_name LIKE '$pattern'
               AND sql NOT NULL UNION ALL SELECT sql FROM sqlite_temp_master
               WHERE tbl_name LIKE '$pattern' AND sql NOT NULL"
      $v(db) eval {PRAGMA database_list} {
         if {$name!="temp" && $name!="main"} {
            append cmd " UNION ALL SELECT sql FROM $name.sqlite_master\
                        WHERE tbl_name LIKE '$pattern' AND sql NOT NULL"
         }
      }
    } elseif {$word==".schema"} {
      set pattern %
      regexp {^.[a-z]+ +([^ ]+)} $cmd all pattern
      set mode list
      set header 0
      set cmd "SELECT sql FROM sqlite_master WHERE name LIKE '$pattern'
               AND sql NOT NULL UNION ALL SELECT sql FROM sqlite_temp_master
               WHERE name LIKE '$pattern' AND sql NOT NULL"
      $v(db) eval {PRAGMA database_list} {
         if {$name!="temp" && $name!="main"} {
            append cmd " UNION ALL SELECT sql FROM $name.sqlite_master\
                        WHERE name LIKE '$pattern' AND sql NOT NULL"
         }
      }
    } else {
      return \
        ".exit\n.mode line|list|column\n.schema ?TABLENAME?\n.tables"
    }
  }
  set res {}
  if {$mode=="list"} {
    $v(db) eval $cmd x {
      set sep {}
      foreach col $x(*) {
        append res $sep$x($col)
        set sep |
      }
      append res \n
    }
    if {[info exists x(*)] && $header} {
      set sep {}
      set hdr {}
      foreach col $x(*) {
        append hdr $sep$col
        set sep |
      }
      set res $hdr\n$res
    }
  } elseif {[string range $mode 0 2]=="col"} {
    set y {}
    $v(db) eval $cmd x {
      foreach col $x(*) {
        if {![info exists cw($col)] || $cw($col)<[string length $x($col)]} {
           set cw($col) [string length $x($col)]
        }
        lappend y $x($col)
      }
    }
    if {[info exists x(*)] && $header} {
      set hdr {}