1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658
|
#!/usr/bin/tclsh
# From version 2.0.0 on, pfm.tcl is called without arguments
#######################################################################
# This is Postgres Forms (pfm), a client application for PostgreSQL.
#
# Copyright (C) 2004-2013 Willem Herremans
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
#
# The home page for the pfm project is at
#
# http://pgfoundry.org/projects/pfm/
#
# There you can report bugs, request new features and get support.
#
#######################################################################
package require Tcl
package require msgcat
namespace import ::msgcat::mc
package require Itcl
namespace import itcl::class itcl::code itcl::delete itcl::scope
package require Tk
# config.tcl
source [file join [file dirname [file normalize [info script]]] config.tcl]
# options.tcl
source [file join $config::installDir options.tcl]
# misc.tcl
source [file join $config::installDir misc.tcl]
# postgresql.tcl
source [file join $config::installDir postgresql.tcl]
# database.tcl
source [file join $config::installDir database.tcl]
# sql.tcl
source [file join $config::installDir sql.tcl]
# forms.tcl
source [file join $config::installDir forms.tcl]
# reports.tcl
source [file join $config::installDir report.tcl]
class MainWin {
public variable state
protected variable noteBook
public variable fForms
public variable fDesign
public variable fReports
protected variable mnDatabase
protected variable menubar
protected variable mnTools
protected variable mnHelp
protected variable sqlObject {}
constructor {} {
wm title . [mc pfm_no_database]
wm geometry {.} [join $::geometry::main {x}]
set db {}
initWindow
setState closed
set tpOnly [bindToplevelOnly {.} <Destroy> [list delete object $this]]
bind $tpOnly <Configure> {set ::geometry::main {%w %h}}
return
}
destructor {
# Cleanup before closing down application
if {$state ne {closed}} then {
$::dbObject closedb
}
$::pfmOptions setOption geometry main $::geometry::main
$::pfmOptions setOption geometry sql $::geometry::sql
$::pfmOptions setOption geometry form $::geometry::form
$::pfmOptions setOption geometry text $::geometry::text
$::pfmOptions saveOptions
foreach file $::tmpFiles {
file delete $file
}
# puts "on exit: [::itcl::find objects]"
return
}
protected method setState {newstate} {
set state $newstate
switch $state {
"open" {
wm title . "pfm - [$::dbObject cget -dbname]"
$menubar entryconfigure 1 -state normal
$mnDatabase entryconfigure 0 -state disabled
$mnDatabase entryconfigure 1 -state normal
$mnTools entryconfigure 0 -state disabled
$mnTools entryconfigure 1 -state disabled
}
"notables" {
wm title . "pfm - [$::dbObject cget -dbname]"
$menubar entryconfigure 1 -state normal
$mnDatabase entryconfigure 0 -state disabled
$mnDatabase entryconfigure 1 -state normal
$mnTools entryconfigure 0 -state normal
$mnTools entryconfigure 1 -state normal
}
default {
wm title . [mc pfm_no_database]
$menubar entryconfigure 1 -state disabled
$mnDatabase entryconfigure 0 -state normal
$mnDatabase entryconfigure 1 -state disabled
$mnTools entryconfigure 0 -state disabled
$mnTools entryconfigure 1 -state disabled
}
}
return
}
public method openDatabase {} {
if {$state eq {closed}} then {
if {[$::dbObject opendb]} then {
check_pfm_tables nrOfTables dbversion
if {$nrOfTables > 0} then {
switch -- [versionCompare $::config::dbversion $dbversion] {
-1 {
# pfm_tables are newer than required
pfm_message [mc pfm_tables_newer \
$::config::dbversion $dbversion] {.}
set newstate open
}
0 {
# pfm_tables have required version
set newstate open
}
1 {
# pfm_tables are older than required
set arg [dict create \
parent {.} \
title [mc convertDB] \
message [mc questionConvertDB \
$::config::dbversion $dbversion] \
msgWidth 400 \
defaultButton btnNo \
buttonList {btnYes btnNo}]
set dlg [GenDialog "#auto" $arg]
if {[$dlg wait] eq {btnYes}} then {
if {[convertDB $dbversion]} then {
set newstate open
} else {
set newstate open
pfm_message [mc oldVersion \
$::config::dbversion $dbversion] {.}
}
} else {
set newstate open
pfm_message [mc oldVersion \
$::config::dbversion $dbversion] {.}
}
}
}
} else {
set newstate notables
pfm_message [mc noTables] {.}
}
setState $newstate
$fForms setState $newstate
$fDesign setState $newstate
$fReports setState $newstate
}
}
return
}
public method closeDatabase {} {
FormWindow::closeAllWindows
if {$sqlObject ne {}} then {
$sqlObject destroyWindow
delete object $sqlObject
set sqlObject {}
}
if {$state ne {closed}} then {
$::dbObject closedb
setState closed
$fForms setState closed
$fDesign setState closed
$fReports setState closed
}
# puts "on close: [::itcl::find objects]"
return
}
public method openSql {} {
if {$sqlObject eq {}} then {
set sqlObject [Sql "#auto" {.}]
} else {
$sqlObject showWindow
}
return
}
public method displayHelp {} {
set helpFolder [file join $::config::docDir en]
foreach locale [lrange [::msgcat::mcpreferences] 0 end-1] {
set translatedFolder [file join $::config::docDir $locale]
if {[file exists $translatedFolder] && \
[file isdirectory $translatedFolder]} then {
set helpFolder $translatedFolder
break
}
}
set url "file://${helpFolder}/index.html"
set command {exec}
set map {%s}
lappend map $url
foreach arg [$::pfmOptions getOption general browser] {
lappend command [string map $map $arg]
}
lappend command {&}
if { [catch $command errMsg]} then {
pfm_message [mc browser_failed $command $errMsg] {.}
}
return
}
public method displayLicense {} {
set filename [file join $::config::licenseDir gpl.txt]
foreach locale [lrange [::msgcat::mcpreferences] 0 end-1] {
set translatedFile [file join $::config::licenseDir $locale \
gpl.txt]
if {[file exists $translatedFile]} then {
set filename $translatedFile
break
}
}
if {[catch {open $filename r} chan]} then {
set textEdit [TextEdit "#auto" {.} License $chan 1]
} else {
set textEdit [TextEdit "#auto" {.} License [chan read $chan] 1]
chan close $chan
}
return
}
public method displayAbout {} {
variable ::config::version
variable ::config::installDir
set arg [dict create \
parent {.} \
title pfm \
message [mc about_pfm $version $installDir $::config::API \
[info nameofexecutable] [info patchlevel]] \
msgWidth 500 \
defaultButton btnOK \
buttonList btnOK]
set dlg [GenDialog "#auto" $arg]
return
}
public method installPfmTables {} {
if {$sqlObject eq {}} then {
set sqlObject [Sql "#auto" {.}]
} else {
$sqlObject showWindow
}
set sqlWindow [$sqlObject cget -window]
update
set filename [file join $::config::installDir install_pfm.sql]
if {[file exists $filename]} then {
set message [mc watchScript install_pfm.sql]
pfm_message $message $sqlWindow
$sqlObject executeScript $filename {iso8859-1}
set message [mc pressOkWhenFinished]
pfm_message $message $sqlWindow
setState open
$fForms setState open
$fDesign setState open
$fReports setState open
} else {
pfm_message [mc scriptNotFound $filename] {.}
}
return
}
public method installExample {} {
set initialDir $::config::exampleDir
set title [mc selectExampleDB]
set fromEncoding {iso8859-1}
set fileTypes {
{{SQL statements} {.sql} }
{{All files} *}
}
set defaultExt ".sql"
set filename [tk_getOpenFile -title $title -filetypes $fileTypes \
-defaultextension $defaultExt -parent {.} \
-initialdir $initialDir]
if {($filename ne {}) && [file exists $filename]} then {
if {$sqlObject eq {}} then {
set sqlObject [Sql "#auto" {.}]
} else {
$sqlObject showWindow
}
set sqlWindow [$sqlObject cget -window]
update
set message [mc watchScript [file tail $filename]]
pfm_message $message $sqlWindow
$sqlObject executeScript $filename {iso8859-1}
set message [mc pressOkWhenFinished]
pfm_message $message $sqlWindow
setState open
$fForms setState open
$fDesign setState open
$fReports setState open
}
return
}
public method onTabChange {} {
if {$state eq {open}} then {
$fForms refreshList
$fReports refreshList
$fDesign refreshList
}
return
}
protected method initWindow {} {
. configure -background $::themeBackground
# Define menus
set menubar [menu .mb -tearoff 0]
# Database menu
set mnDatabase [menu $menubar.db -tearoff 0]
addMenuItem $mnDatabase mnuOpen command [list $this openDatabase]
addMenuItem $mnDatabase mnuClose command [list $this closeDatabase]
$mnDatabase add separator
addMenuItem $mnDatabase mnuQuit command [list destroy .]
# accelerators for Database menu
$mnDatabase entryconfigure 0 -accelerator {Cntrl-o}
bind . <Control-KeyPress-o> [list $this openDatabase]
$mnDatabase entryconfigure 1 -accelerator {Cntrl-w}
bind . <Control-KeyPress-w> [list $this closeDatabase]
$mnDatabase entryconfigure 3 -accelerator {Cntrl-q}
bind . <Control-KeyPress-q> [list destroy .]
# Tools menu
set mnTools [menu $menubar.tools -tearoff 0]
addMenuItem $mnTools mnuInstallTables command [list $this installPfmTables]
addMenuItem $mnTools mnuInstallExample command [list $this installExample]
addMenuItem $mnTools mnuOptions command [list $::pfmOptions editOptions]
$mnTools add separator
addMenuItem $mnTools mnuIncrFont command [list $this changeFontSize 1]
addMenuItem $mnTools mnuDecrFont command [list $this changeFontSize -1]
$mnTools entryconfigure 4 -accelerator {Cntrl +}
$mnTools entryconfigure 5 -accelerator {Cntrl -}
bind all <Control-KeyPress-plus> [list $this changeFontSize 1]
bind all <Control-KeyPress-minus> [list $this changeFontSize -1]
# Help menu
set mnHelp [menu $menubar.help -tearoff 0]
addMenuItem $mnHelp mnuHelpFile command [list $this displayHelp]
addMenuItem $mnHelp mnuLicense command [list $this displayLicense]
addMenuItem $mnHelp mnuAbout command [list $this displayAbout]
# Accelerators for Help menu
$mnHelp entryconfigure 0 -accelerator {F1}
bind . <KeyPress-F1> [list $this displayHelp]
# connect submenus to menubar
addMenuItem $menubar mnuDatabase cascade $mnDatabase
addMenuItem $menubar mnuSQL command [list $this openSql]
addMenuItem $menubar mnuTools cascade $mnTools
addMenuItem $menubar mnuHelp cascade $mnHelp
. configure -menu $menubar
# Define notebook
set noteBook [ttk::notebook .nb -takefocus 0]
set fForms [ListTab "#auto" $noteBook forms]
set fDesign [ListTab "#auto" $noteBook design]
set fReports [ListTab "#auto" $noteBook reports]
addNotebookTab $noteBook [$fForms cget -widget] tabForms
addNotebookTab $noteBook [$fReports cget -widget] tabReports
addNotebookTab $noteBook [$fDesign cget -widget] tabDesign
ttk::notebook::enableTraversal $noteBook
pack $noteBook -fill both -expand 1
pack [ttk::sizegrip .sg] -side top -anchor e
bind $noteBook <<NotebookTabChanged>> [list $this onTabChange]
return
}
public method changeFontSize {increment} {
foreach font {TkDefaultFont TkTextFont TkFixedFont TkMenuFont TkHeadingFont} {
set size [font configure $font -size]
if {$size > 0} then {
font configure $font -size [expr $size + $increment]
} else {
font configure $font -size [expr $size - $increment]
}
}
return
}
protected method convertDB {fromVersion} {
if {$sqlObject eq {}} then {
set sqlObject [Sql "#auto" {.}]
} else {
$sqlObject showWindow
}
set sqlWindow [$sqlObject cget -window]
update
switch -- $fromVersion {
{1.0.4} {
set scriptList {{1.0.4} {1.1.0} {1.2.0}}
}
{1.1.0} -
{1.1.1} {
set scriptList {{1.1.0} {1.2.0}}
}
{1.2.0} -
{1.2.1} -
{1.2.3} -
{1.2.4} -
{1.2.5} {
set scriptList {1.2.0}
}
default {
set scriptList {}
}
}
foreach script $scriptList {
set filename [file join $::config::installDir \
convert_from_${script}.sql]
if {[file exists $filename]} then {
set message [mc watchScript convert_from_${script}.sql]
pfm_message $message $sqlWindow
$sqlObject executeScript $filename {iso8859-1}
} else {
pfm_message [mc scriptNotFound $filename] {.}
}
}
set message [mc pressOkWhenFinished]
pfm_message $message $sqlWindow
check_pfm_tables nrOfTables dbversion
set converted [string equal $::config::dbversion $dbversion]
return $converted
}
}
class ListTab {
public variable tabType
public variable widget
protected variable parent
public variable treeview
protected variable btn
protected variable state
protected variable itemList
constructor {c_parent c_type} {
set parent $c_parent
set tabType $c_type
set widget [ttk::frame $parent.[namespace tail $this] -takefocus 0]
set frm1 [ttk::frame $widget.frm1 -takefocus 0]
set frm2 [ttk::frame $widget.frm2 -takefocus 0]
switch $tabType {
forms {
set treeview [ttk::treeview $frm1.tv -columns forms \
-show {headings} -selectmode browse -height 1]
$treeview heading forms -text [mc lblForms]
set btn [defineButton $frm2.btn $widget btnOpen \
[list $this onOpen]]
pack $btn -side right
}
design {
set treeview [ttk::treeview $frm1.tv -columns forms \
-show {headings} -selectmode browse -height 1]
$treeview heading forms -text [mc lblDesign]
set btn [defineButton $frm2.btn $widget btnOpen \
[list $this onOpen]]
pack $btn -side right
}
reports {
set treeview [ttk::treeview $frm1.tv \
-columns {reports description} \
-show {headings} -selectmode browse -height 1]
$treeview heading reports -text [mc lblReports]
$treeview heading description -text [mc lblDescription]
$treeview column reports -stretch 0 -width 150
set btn [defineButton $frm2.btn $widget btnRun \
[list $this onRun]]
pack $btn -side right
}
}
set vsb [ttk::scrollbar $frm1.vsb -orient vertical \
-command [list $treeview yview]]
$treeview configure -yscrollcommand [list $vsb set]
grid $treeview -row 0 -column 0 -sticky wens
grid $vsb -row 0 -column 1 -sticky ns
grid rowconfigure $frm1 0 -weight 1
grid columnconfigure $frm1 0 -weight 1
pack $frm1 -side top -expand 1 -fill both
pack $frm2 -side top -fill x -pady {10 10} -padx {10 10}
setState closed
focus $treeview
recursiveAppendTag $widget $widget
bind $widget <KeyPress-Return> \
[list $btn instate {!disabled} [list $btn invoke]]
return
}
destructor {
return
}
public method setState {newstate} {
set state $newstate
switch $newstate {
"open" {
$btn state {!disabled}
$treeview state {!disabled}
refreshList
}
"closed" {
$btn state {disabled}
$treeview delete [$treeview children {}]
$treeview state {disabled}
}
"notables" {
$btn state {disabled}
$treeview state {disabled}
}
}
return
}
public method refreshList {} {
set itemList {}
$treeview delete [$treeview children {}]
foreach item [getFormsReports $::dbObject $tabType] {
lappend itemList [$treeview insert {} end -values $item]
}
if {[llength $itemList]} then {
$btn state {!disabled}
$treeview state {!disabled}
$treeview focus [lindex $itemList 0]
$treeview selection set [lindex $itemList 0]
} else {
$btn state {disabled}
$treeview state {disabled}
}
return
}
public method onOpen {} {
set formName [lindex [$treeview item [$treeview selection] -values] 0]
set form [FormWindow "#auto" {.} $formName]
return
}
public method onRun {} {
set reportName [lindex [$treeview item [$treeview selection] -values] 0]
set reportObject [Report "#auto" {.} $reportName]
return
}
}
# Main
# create and init options object
set pfmOptions [PfmOptions "#auto"]
$pfmOptions initOptions
set tmpFiles {}
namespace eval geometry {
foreach window {main sql form text} {
variable $window
set $window [$::pfmOptions getOption geometry $window]
}
}
# Style issues
proc installTheme {theme} {
global readonlyBackground
global themeBackground
global tcl_platform
set readonlyBackground {#F3F0EB}
if {[catch {ttk::style theme use $theme} errMsg]} then {
ttk::style theme use default
$::pfmOptions setOption general theme default
}
# smaller button
ttk::style layout SButton [ttk::style layout TButton]
ttk::style configure SButton {*}[ttk::style configure TButton]
ttk::style configure SButton -width -6 -padding {4 1}
# Left aligned smaller button
ttk::style layout LButton [ttk::style layout TButton]
ttk::style configure LButton {*}[ttk::style configure TButton]
ttk::style configure LButton -anchor w -width -6 -padding {4 1}
ttk::style map TCombobox -fieldbackground [list readonly $readonlyBackground]
set themeBackground [ttk::style lookup TFrame -background]
option clear
option add *Canvas.background $themeBackground
option add *Canvas.highlightThickness 0
option add *Toplevel.background $themeBackground
option add *Message.background $themeBackground
option add *Entry.highlightThickness 1
option add *Entry.highlightColor {SteelBlue4}
option add *Entry.readonlyBackground $readonlyBackground
option add *Entry.background {White}
option add *Text.background {White}
if {$tcl_platform(platform) eq {unix}} then {
set activeBackground [ttk::style lookup TButton -background active]
set activeForeground [ttk::style lookup TButton -foreground active]
option add *Menu.background $themeBackground
option add *Menu.activeBackground $activeBackground
option add *Menu.activeForeground $activeForeground
}
return
}
installTheme [$::pfmOptions getOption general theme]
bind TButton <KeyPress-Return> {event generate %W <KeyPress-space>}
bind TCheckbutton <KeyPress-Return> {event generate %W <KeyPress-space>}
bind TRadiobutton <KeyPress-Return> {event generate %W <KeyPress-space>}
bind Button <KeyPress-Return> {event generate %W <KeyPress-space>}
bind Checkbutton <KeyPress-Return> {event generate %W <KeyPress-space>}
bind Radiobutton <KeyPress-Return> {event generate %W <KeyPress-space>}
# Load user interface strings
::msgcat::mcload $::config::languageDir
set dbObject [PostgresqlApi "#auto"]
set pfmObject [MainWin "#auto"]
::ContextMenu::setup
|