# ------------------------------------------------------------ # Copyright (c) 2003-2021 # Q.W.Page Associates Inc. # www.qwpage.com # All rights reserved. # ------------------------------------------------------------ /* { pgq__master -> tree_new_observers.qw_tcl ::if {$::qw::control(observer_builtins_are_eliminated)} { method odb_observer_create {args} { #pgq__master ::puts "rwb__debug,odb_object,tree,odb_observer_create,1000.0,this==$this,args==$args"; ::if {![::eval ::sargs::marshal_is_legacy $args]} { ::sargs::marshal; ::sargs::var::set sargs .outer $this; ::return [$this cpp_odb_object_odb_observer_create $sargs]; } ::switch -- [::llength $args] { 1 { ::puts "rwb__debug,odb_object,tree,odb_observer_create,1000.2"; ::return [$this cpp_odb_object_odb_observer_create .outer $this .tag [::lindex $args 0]]; } 2 { ::puts "rwb__debug,odb_object,tree,odb_observer_create,1000.3"; ::return [$this cpp_odb_object_odb_observer_create .outer $this .tag [::lindex $args 0] .observee [::lindex $args 1]]; } 3 { ::puts "rwb__debug,odb_object,tree,odb_observer_create,1000.4"; ::return [$this cpp_odb_object_odb_observer_create .outer $this .tag [::lindex $args 0] .observee [::lindex $args 1] .command_list [::lindex $args 2]]; } default { ::qw::bug 314120181220094206 "odb_observer_create - invalid args \"$args\"."; } } } # method odb_observer_destroy {Tag} {::return [$this cpp_odb_object_odb_observer_destroy .tag $Tag];} method odb_observer_destroy {Tag} { #pgq__master ::puts "rwb__debug,tree,odb_observer_destroy,1000.0,this==$this" ::if {[::info exists _odb_observers($Tag)]} { ::puts "rwb__debug,tree,odb_observer_destroy,1000.1" $_odb_observers($Tag) cpp_destroy; ::puts "rwb__debug,tree,odb_observer_destroy,1000.2" ::unset _odb_observers($Tag); ::puts "rwb__debug,tree,odb_observer_destroy,1000.3" } ::puts "rwb__debug,tree,odb_observer_destroy,1000.4" } method odb_observer_set {Tag Observee} { #pgq__master ::puts "rwb__debug,tree,odb_observer_set,1000.0,this==$this" ::if {[::info exists _odb_observers($Tag)]} { ::puts "rwb__debug,tree,odb_observer_set,1000.1" $_odb_observers($Tag) cpp_odb_observer_odb_observee_set .observee $Observee; ::puts "rwb__debug,tree,odb_observer_set,1000.2" } ::puts "rwb__debug,tree,odb_observer_set,1000.3" } method odb_observer_get {Tag} { #pgq__master ::puts "rwb__debug,tree,odb_observer_get,1000.0,this==$this" ::set Result ""; ::puts "rwb__debug,tree,odb_observer_get,1000.1" ::if {[::info exists _odb_observers($Tag)]} { ::puts "rwb__debug,tree,odb_observer_get,1000.2" ::set Result [$_odb_observers($Tag) cpp_odb_observer_odb_observee_get]; ::puts "rwb__debug,tree,odb_observer_get,1000.3" } ::puts "rwb__debug,tree,odb_observer_get,1000.4" ::return $Result; } method odb_observer_commands_set {Tag List} { #pgq__master ::puts "rwb__debug,tree,odb_observer_commands_set,1000.0,this==$this" ::if {[::info exists _odb_observers($Tag)]} { ::puts "rwb__debug,tree,odb_observer_commands_set,1000.1" $_odb_observers($Tag) cpp_command_list_set .command_list $List; ::puts "rwb__debug,tree,odb_observer_commands_set,1000.2" } ::puts "rwb__debug,tree,odb_observer_commands_set,1000.3" } method odb_observer_commands_get {Tag} { #pgq__master ::puts "rwb__debug,tree,odb_observer_commands_get,1000.0,this==$this" ::set Result ""; ::if {[::info exists _odb_observers($Tag)]} { ::puts "rwb__debug,tree,odb_observer_commands_get,1000.1" ::set Result [$_odb_observers($Tag) cpp_command_list_get]; ::puts "rwb__debug,tree,odb_observer_commands_get,1000.2" } ::puts "rwb__debug,tree,odb_observer_commands_get,1000.3" ::return $Result; } } else { method odb_observer_create {Tag {Handle ""} {Commands ""}} @qw_odb_object_odb_observer_create; method odb_observer_destroy {Tag} @qw_odb_object_odb_observer_destroy; method odb_observer_set {Tag Handle} @qw_odb_object_odb_observer_set; method odb_observer_get {Tag} @qw_odb_object_odb_observer_get; } */ } # ------------------------------------------------------------ # ::QW::ODB::OBJECT class # ------------------------------------------------------------ ::qw::itcl::class ::QW::ODB::OBJECT { protected variable _odb_observers; method puts_pgq {Arg} { ::if {!$::qw::verbose(gui)} {::return $Arg;} # return ""; ::puts -nonewline "[[odb_database] cpp_database_path]-[odb_path],"; ::uplevel 1 ::puts $Arg; } method puts_pgq_apply {Arg} { ::if {!$::qw::verbose(gui_apply)} {::return $Arg;} # return ""; ::puts -nonewline "[[odb_database] cpp_database_path]-[odb_path],"; ::uplevel 1 ::puts $Arg; } method odb_initialize {} { } destructor { odb_observers_destroy; } method "" {args} { ::qw::bug "314120040830144312" "Called method \"\" on [odb_path] with args \"$args\"."; } method odb_path {} {::return [$this cpp_odb_object_odb_path]}; method odb_path_from_object {Object} {::return [$this cpp_odb_object_odb_path_from_object .object $Object]}; method odb_path_from_master {} {::return [$this cpp_odb_object_odb_path_from_master]}; method odb_path_from_outer {} {::return [$this cpp_odb_object_odb_path_from_outer]}; method odb_path_readable {} {::return [$this cpp_odb_object_odb_path_readable]}; method odb_path_help {} {::return [$this cpp_odb_object_odb_path_help]}; method odb_master {} {::return [$this cpp_odb_object_odb_master]}; method odb_base {} {::return [$this cpp_odb_object_odb_base]}; method odb_super {} {::return [$this cpp_odb_object_odb_super]}; method odb_outer {} {::return [$this cpp_odb_object_odb_outer]}; method odb_build_field_help_tree {sargs} {::return [$this cpp_odb_object_odb_build_field_help_tree $sargs];} method tcl_class {} {::return [$this cpp_odb_object_tcl_class];} method tcl_base {} {::return [$this cpp_odb_object_tcl_base];} method tcl_definition {{Arg ""}} {::if {$Arg ne ""} {::return [$this cpp_tcl_definition $Arg];} else {::return [$this cpp_tcl_definition];}} method odb_database {{DatabaseType ""}} {::return [$this cpp_odb_object_odb_database .database_type $DatabaseType];} method odb_signal_send {sargs} {::return [$this cpp_odb_object_odb_signal_send $sargs];} method signal_receive {sargs} {::return [$this cpp_odb_object_odb_signal_receive $sargs];} method odb_is_a {Ancestor} {::return [$this cpp_odb_object_odb_is_a .ancestor $Ancestor];} method odb_address {} {::return [$this cpp_odb_object_odb_address];} method odb_id {} {::return [$this cpp_odb_object_odb_id];} method odb_destroy_before {sargs} {::return [$this cpp_odb_object_odb_destroy_before $sargs];} method odb_user {} {::return [[odb_database] cpp_user_get];} method odb_user_name {} { ::set User [[odb_database] cpp_user_get]; ::if {$User ne ""} { ::return [[$User ".name"] odb_get]; } ::return ""; } /* { method odb_database_autocommit {{Arg ""}} { ::set Database [odb_database $Arg]; ::if {[$Database cpp_is_processing_external_signal]} {::return $this;} # $Manager cpp_commit ".window 0"; # $Database cpp_commit; $Database cpp_commit; # [$Database "/OBJECT"] odb_commit; # $Database cpp_gatgun_queue_commit; # $Database cpp_ping; return $this; } */ } /* { if (!odb_base()) return odb_id_readable(); // cout<<"QW::ODB::MASTER::odb_path_readable(),_odb_id=="<<_odb_id<<",odb_id=="<odb_path_readable=="<odb_path_readable()<<",odb_id_readable()=="<odb_path_readable()+odb_id_readable(); */ } /* { ::if {$::qw::control(builtins_are_eliminated)} { method odb_observer_create {Tag {Handle ""} {Commands ""}} {::return [$this cpp_odb_object_odb_observer_create .tag $Tag .handle $Handle .commands $Commands];} method odb_observer_destroy {Tag} {::return [$this cpp_odb_object_odb_observer_destroy .tag $Tag];} method odb_observer_set {Tag Handle} {::return [$this cpp_odb_object_odb_observer_set .tag $Tag .handle $Handle];} method odb_observer_get {Tag} {::return [$this cpp_odb_object_odb_observer_get .tag $Tag];} method odb_observers_destroy {} { ::foreach Tag [::array names _odb_observers] { odb_observer_destroy $Tag; } } method odb_observer_commands_set {Tag Commands} {::return [$this cpp_odb_object_odb_observer_commands_set .tag $Tag .commands $Commands];} method odb_observer_commands_get {Tag} {::return [$this cpp_odb_object_odb_observer_commands_get .tag $Tag];} } */ } ::if {$::qw::control(observer_builtins_are_eliminated)} { method odb_observer_create {args} { ::if {![::eval ::sargs::marshal_is_legacy $args]} { ::sargs::marshal; ::sargs::var::set sargs .outer $this; ::sargs::var::set sargs .outer_is_odb_object 1; ::return [[::qw::system] .this $this cpp_odb_observer_create $sargs]; } ::set sargs [::sargs .outer $this .outer_is_odb_object 1]; ::switch -- [::llength $args] { 1 { ::return [[::qw::system] cpp_odb_observer_create $sargs .tag [::lindex $args 0]]; } 2 { ::return [[::qw::system] cpp_odb_observer_create $sargs .tag [::lindex $args 0] .handle [::lindex $args 1]]; } 3 { ::return [[::qw::system] cpp_odb_observer_create .sargs .tag [::lindex $args 0] .handle [::lindex $args 1] .command_list [::lindex $args 2]]; } default { ::qw::bug 314120181220094206 "odb_observer_create - invalid args \"$args\"."; } } } # method odb_observer_destroy {Tag} {::return [$this cpp_odb_object_odb_observer_destroy .tag $Tag];} method odb_observer_destroy {Tag} { ::if {[::info exists _odb_observers($Tag)]} { $_odb_observers($Tag) cpp_destroy; ::unset _odb_observers($Tag); } } method odb_observer_set {Tag Handle} { ::if {[::info exists _odb_observers($Tag)]} { [::qw::system] cpp_odb_observer_set .observer $_odb_observers($Tag) .handle $Handle; } } method odb_observer_get {Tag} { ::set Result ""; ::if {[::info exists _odb_observers($Tag)]} { ::set Result [[::qw::system] cpp_odb_observer_get .observer $_odb_observers($Tag)]; } ::return $Result; } method odb_observer_commands_set {Tag List} { ::if {[::info exists _odb_observers($Tag)]} { [::qw::system] cpp_command_list_set .observer $_odb_observers($Tag) .command_list $List; } } method odb_observer_commands_get {Tag} { ::set Result ""; ::if {[::info exists _odb_observers($Tag)]} { ::set Result [[::qw::system] cpp_command_list_get .observer $_odb_observers($Tag)]; } ::return $Result; } } ::if {!$::qw::control(observer_builtins_are_eliminated)} { method odb_observer_create {Tag {Handle ""} {Commands ""}} @qw_odb_object_odb_observer_create; method odb_observer_destroy {Tag} @qw_odb_object_odb_observer_destroy; method odb_observer_set {Tag Handle} @qw_odb_object_odb_observer_set; method odb_observer_get {Tag} @qw_odb_object_odb_observer_get; method odb_observer_commands_set {Tag List} @qw_odb_object_odb_observer_commands_set; method odb_observer_commands_get {Tag} @qw_odb_object_odb_observer_commands_get; } method odb_observers_destroy {} { ::foreach Tag [::array names _odb_observers] { odb_observer_destroy $Tag; } } # method odb_observer_create {Tag {Handle ""} {Commands ""}} @qw_odb_object_odb_observer_create; method odb_id_readable {} {::return "";} method odb_security_check {sargs} {} method unique_id {} { ::return [::qw::id_factory]; } method odb_created {} {::return $this;} method window_commit_callback {sargs} {} method nv1DateToTclDate {Src} { /* { We are taking a date in NV1 keystroke format and converting it to a tcl date, which a number representing a date in the year range 1902 to 2031. */ } #//RTH ::set Year [::string range $Src 4 7]; ::if {$Year<1902} { ::puts "Warning:\tNV1 date \"$Src\" contains invalid year. Forcing year to 1970."; ::set Src "[::string range $Src 0 3]1970"; } ::if {$Src==""} {::set Src 19851231;} ::if {$Src==0} {::set Src 19851231;} # ::if {$Src==""} {::return "";} # ::if {$Src==0} {::return "";} ::if {[::string length $Src]!=8} {::qw::throw "Invalid Nv1 date \"$Src\". Date must have length 8 but has length [::string length $Src].";} ::set Result [::clock scan [::string range $Src 2 3]/[::string range $Src 0 1]/[::string range $Src 4 7]]; return $Result; } method odb_help {s_args} { return ""; } method qw_structure {args} { ::if {[odb_is_remote]} { ::return [::eval odb_remote_call qw_structure $args]; } ::return ""; } method info {args} { if {[::llength $args] == 2 && [::lindex $args 0] eq "body"} { ::qw::throw "Attempted to access the method body of a qw odb class."; } ::return [::eval chain $args]; } method odb_method_subst {Script Locals} { /* { This method is called from the odb when we need to perform a subst. The script is evaluated within the context of a method on the object and variables are set according to Locals so that at the time of the subst they are local variables in the method. The locals argument contains an even-sized list of name/value pairs. The first item of each pair is a variable name such as Reference. The second is a value. Each local variable is set to its value before the subst is invoked so it will be a local variable in the method. Without this generic method we would need many separate methods for different subst operations. */ } ::foreach {Name Value} $Locals { ::set $Name $Value; } ::return [::subst $Script]; } method odb_super_find_by_id {Id} { /* { This helper method simply determines whether the object has a super ancestor with the given id and returns its address or "" if no super ancestor with the id exists. This is useful for postings that need to quickly determine whether they are under the /debit or /credit nodes. The node itself is also checked. */ } ::for {::set Object $this;} {$Object ne ""} {::set Object [$Object odb_super]} { ::if {[$Object odb_id] eq $Id} { ::return $Object; } } return ""; } /* { method call_after_qwidle {Command Object Method} { ::return [::qw::after idle [::subst -nocommands {::if {[::string length [::info commands $Object]]} {$Object $Method}}]]; } */ } /* { method odb_window_manager {} { ::if {![::info exists ::qw::odb_window_manager]} {::qw::bug 314120040119114626 "The window manager does not exist.";} ::if {$::qw::odb_window_manager eq ""} {::qw::bug 314120040119114725 "The window manager does not exist.";} ::return $::qw::odb_window_manager; } */ } method odb_is_class {} {::return [$this cpp_odb_object_odb_is_class];} method odb_is_window {} {::return [$this cpp_odb_object_odb_is_window];} method odb_is_remote {} {::return [$this cpp_odb_object_odb_is_remote];} method odb_remote_call {args} {::return [$this cpp_odb_object_odb_remote_call .method [::lindex $args 0] .args [::lrange $args 1 end]];} method odb_mode {} {::return [$this cpp_odb_object_odb_mode];} method odb_id_factory {} {::return [[odb_database] cpp_odb_id_factory];} /* { method qw_data_file_normalize {Path} { /* { qw_data_file_normalize was added for print templates. They are included in the vfs and installed in the same directory within $::qw_data. */ } ::if {[::file pathtype $Path] eq "relative"} { ::return [::string tolower [::file join $::qw_data $Path]]; } ::return [::string tolower [::file normalize $Path]]; } method qw_data_file_unnormalize {Path} { ::return [::string tolower [::string map "{$::qw_data/} {}" $Path]]; } */ } method qw_data_file_make_absolute {Path} { /* { qw_data_file_normalize was added for print templates. They are included in the vfs and installed in the same directory within $::qw_data. 2.23.0 Print templates are now relative to .../print_templates/my_templates. We also check against nv2.dat for backward compatibility. */ } ::if {[::file pathtype $Path] eq "relative"} { ::while {1} { ::set Path1 [::string tolower [::file join $::qw_data $Path]]; ::if {[::file exists $Path1]} { ::set Path $Path1; ::break; } ::set Path1 [::string tolower [::file join $::qw_program_folder print_templates my_templates $Path]]; ::if {[::file exists $Path1]} { ::set Path $Path1; ::break; } ::set Path [::string tolower [::file join $::qw_data $Path]]; break; } } ::return [::string tolower [::file normalize $Path]]; } method qw_data_file_make_relative {Path} { #2.23 ::return [::string tolower [::string map "{$::qw_data/} {}" $Path]]; ::return [::string tolower [::string map [::list $::qw_data ""] $Path]]; } # method odb_clear_local_upward_closure_memory_cache {sargs} {::return 0;} method odb_field_help_ids {sargs} {::return "";} method odb_base_from_reference {} { /* { The odb_base method gets the hard-wired internal base. When we added the ability to change the base of an object such as an account, we needed the before and after closures to stop using the odb_base method because the internal odb_base method does not respect before and after modes. Instead, we now use this method which gets the base of any field through the .odb_base field which, like any reference or other field, respects the before and after modes. */ } ::set FieldPath [odb_path_from_master]; ::set MasterBase [[odb_master] odb_base_from_reference]; ::if {$MasterBase eq ""} { return ""; } ::if {![::qw::command_exists $MasterBase$FieldPath]} { ::return ""; } ::return $MasterBase$FieldPath; } } # ------------------------------------------------------------ # QW::ODB::FIELD class # ------------------------------------------------------------ ::qw::itcl::class ::QW::ODB::FIELD { inherit ::QW::ODB::OBJECT; method odb_id_readable {} {::return [odb_id];} method odb_super_base {} {::return [$this cpp_super_base];} method odb_inners_ids {} {::return [$this cpp_odb_field_odb_inners_ids]}; method odb_subs_ids {} {::return [$this cpp_odb_field_odb_subs_ids]}; method odb_inners_factory {args} { ::set sargs [::eval ::sargs::hyphen_to_dot $args]; ::set Result [$this cpp_odb_field_odb_inners_factory $sargs]; ::return $Result; }; method odb_subs_factory {args} { ::set sargs [::eval ::sargs::hyphen_to_dot $args]; ::set Result [$this cpp_odb_field_odb_subs_factory $sargs]; ::return $Result; }; method qw_structure {args} { ::if {[odb_is_remote]} { ::return [::eval chain $args]; } ::set Result [::eval chain $args]; ::foreach Name [odb_inners_ids] { #pgqexperiment ::sargs::var::set Result $Name [::eval [$this $Name] qw_structure $args]; } ::foreach Name [odb_subs_ids] { ::sargs::var::set Result $Name [::eval [$this $Name] qw_structure $args]; } # ::set Result [::sargs::set $Result .tcl_class [$this tcl_class]]; # ::set Result [::sargs::set $Result .tcl_base [$this tcl_base]]; # ::set Result [::sargs::set $Result .tcl_definition [$this tcl_definition]]; return $Result; } /* { method qw_structure {args} { ::set Result [::eval chain $args]; ::array set Args $args; ::if {[::info exists Args(-command)]} { ::switch -- $Args(-command) { "copy" { ::foreach Name [odb_inners_ids] { ::set Kid [::eval [$this $Name] qw_structure $args]; ::if {$Kid ne ""} {::sargs::var::set Result $Name $Kid;} } ::foreach Name [odb_subs_ids] { ::set Kid [::eval [$this $Name] qw_structure $args]; ::if {$Kid ne ""} {::sargs::var::set Result $Name $Kid;} } ::return $Result; } } ::qw::bug 314120040316151832 "qw_structure did not recognize -command \"$Args(-command)\"."; } ::foreach Name [odb_inners_ids] { #pgqexperiment ::sargs::var::set Result $Name [::eval [$this $Name] qw_structure $args]; } ::foreach Name [odb_subs_ids] { ::sargs::var::set Result $Name [::eval [$this $Name] qw_structure $args]; } # ::set Result [::sargs::set $Result .tcl_class [$this tcl_class]]; # ::set Result [::sargs::set $Result .tcl_base [$this tcl_base]]; # ::set Result [::sargs::set $Result .tcl_definition [$this tcl_definition]]; ::return $Result; } */ } method odb_class_path {} { # 2.35.5 # added this method in order to find a bug # somebody is calling odb_class_path on a non-master ::qw::stack_dump; ::qw::bug 314120220516165955 "odb_class_path - called on non-master object [odb_path]"; } } ::qw::itcl::class ::QW::ODB::MASTER { # ------------------------------------------------------------ # QW::ODB::MASTER class # ------------------------------------------------------------ inherit ::QW::ODB::FIELD; # method odb_handle {} @qw_odb_master_odb_handle; # protected variable _befores_are_set 0; #2.09 method odb_is_destroying {} @qw_odb_master_odb_is_destroying; #2.09 method odb_is_destroyed {} @qw_odb_master_odb_is_destroyed; method odb_object_id {} {::return [$this cpp_odb_master_odb_object_id];} method odb_is_created {} {::return [$this cpp_odb_master_odb_is_created];} method odb_class_path {} {::return [$this cpp_odb_master_odb_class_path];} method odb_abort {sargs} {::return [$this cpp_odb_master_odb_abort $sargs];} method odb_destroy {sargs} {::return [$this cpp_odb_master_odb_destroy $sargs];} method odb_cache_attach {} {::return [$this cpp_odb_master_odb_cache_attach];} method odb_cache_detach {} {::return [$this cpp_odb_master_odb_cache_detach];} method odb_cache_make_first {} {::return [$this cpp_odb_master_odb_cache_make_first];} method odb_cache_make_last {} {::return [$this cpp_odb_master_odb_cache_make_last];} method odb_kids_factory {args} { ::set sargs [::eval ::sargs::hyphen_to_dot $args]; ::set Result [$this cpp_odb_master_odb_kids_factory $sargs]; ::return $Result; }; method odb_kickout {sargs} {::return [$this cpp_odb_master_odb_kickout $sargs];} method odb_kickout_query {sargs} {::return [$this cpp_odb_master_odb_kickout_query $sargs];} method odb_closure_is_set {sargs} {::return [$this cpp_odb_master_odb_closure_is_set $sargs];} method odb_closure_get {sargs} {::return [$this cpp_odb_master_odb_closure_get $sargs];} method odb_closure_set {sargs} {::return [$this cpp_odb_master_odb_closure_set $sargs];} method odb_closure_clear {sargs} {::return [$this cpp_odb_master_odb_closure_clear $sargs];} method odb_closures_clear {} {::return [$this cpp_odb_master_odb_closures_clear];} method odb_signal_memory_kids {sargs} {::return [$this cpp_odb_master_odb_signal_memory_kids];} method odb_memory_kids {sargs} {::return [$this cpp_odb_master_odb_memory_kids];} method odb_cookies_signal_send {sargs} {::return [$this cpp_odb_master_odb_cookies_signal_send];} method odb_meta_get {sargs} {::return [$this cpp_odb_master_odb_meta_get];} method odb_get_structure {sargs} {::return [$this cpp_odb_master_odb_get_structure];} method odb_schedule_for_commit {sargs} {::return [$this cpp_odb_master_odb_schedule_for_commit];} method odb_reference_count_increment {sargs} {::return [$this cpp_odb_master_odb_reference_count_increment];} method odb_object_structure_before {sargs} {::return [$this cpp_odb_master_odb_object_structure_before];} # 2.38.2 method odb_object_structure_current {sargs} {::return [$this cpp_odb_master_odb_object_structure_current];} method odb_path_readable {} { ::if {[odb_base] eq ""} { ::return [odb_id_readable]; } ::return "[[odb_base] odb_path_readable][odb_id_readable]"; } method odb_path_help {} { ::if {[odb_base] eq ""} { ::return [odb_id_readable]; } ::return "[[odb_base] odb_path_help][odb_id_readable]"; } method odb_commit_before {sargs} { ::return [$this cpp_odb_master_odb_commit_before $sargs]; /* { 2.09 Eliminated this method in fields. It is now only in the masters. Also moved any field methods in application to master. Nobody ever uses this signal so why send it? */ } # odb_signal_send [::sargs::set $sargs .command odb_commit_before]; } method odb_commit_now {sargs} { ::return [$this cpp_odb_master_odb_commit_now $sargs]; } method odb_commit_after {sargs} { ::return [$this cpp_odb_master_odb_commit_after $sargs]; } method odb_commit {sargs} { ::return [$this cpp_odb_master_odb_commit $sargs]; } method odb_abort_now {sargs} {} /* { 2.34.5 Nobody at odb level calls it so why have it? method odb__is_committing {sargs} { ::return [$this cpp_odb_master_odb__is_committing $sargs]; } */ } #2.10.3 method odb_objectid {} @qw_odb_master_odb_objectid; /* { 2.10.3 method odb_is_sibling {Arg} { ::if {[odb_is_a $Arg]} {::return 0;} ::if {[$Arg odb_is_a $this]} {::return 0;} ::return 1; } */ } #2.09 method odb_is_dirty {sargs} @qw_odb_master_odb_is_dirty; method odb_change_before {sargs} { odb_security_check ".object $this .operation change"; odb_signal_send [::sargs::set $sargs .command odb_change_before]; } method odb_change_after {sargs} { ::if {$::qw::control(ron_bookmark_bug)} { ::puts "rwb1_debug,odb_change_after,8787.2"; } odb_signal_send [::sargs::set $sargs .command odb_change_after]; ::if {$::qw::control(ron_bookmark_bug)} { ::puts "rwb1_debug,odb_change_after,8787.3"; } } method odb_is_audited {sargs} { ::return 0; } method odb_access_references {} { /* { Returns the references to use when building the access closure. The access closure is the set of all access objects that reference any object in the closure above, where the closure itself is built using the references supplied by this method. This closure is used by the security mechanism and the result is that the current object inherits security from the objects defined by this reference list. By default, security is inherited from the base object. Derived classes will add more references to the list returned by this method. */ } ::return .odb_base; } method odb_access_closure {sargs} { /* { Returns a set of addresses of access objects. This is the set of all access objects that reference objects in the upward closure of this master as defined by the odb_access_references method. If a .user argument is supplied (the address of a user), then the closure is the set of access objects for that user, thus providing security for that user. This method uses the builtin caching mechanism for upward closures. This mechanism is highly efficient compared to building the closure each time it is requested, but it also clears the caches automatically when objects in the closure change. So the closures are built only when necessary. */ } ::if {[odb_is_remote]} { ::return [odb_remote_call odb_access_closure $sargs]; } ::if {[odb_is_window]} { /* { There is effectively no security in a window database. */ } ::return ""; } ::set User [::sargs::get $sargs ".user"]; ::if {$User ne ""} { ::set UserObjectId [$User odb_object_id]; ::if {[[odb_master] odb_closure_is_set .name .access.$UserObjectId]} { /* { The closure is already cached so just return it. */ } ::return [[odb_master] odb_closure_get .name .access.$UserObjectId]; } ::set Closure ""; ::foreach Access [[[$this ".access_froms"] odb_primary] odb_masters] { /* { */ } ::set Collection [[$Access ".user"] odb_get]; ::if {$Collection eq ""} { ::continue; } ::if {$User eq [$Collection odb_master]} { ::set Closure [::qw::union $Closure $Access]; } } ::foreach Reference [odb_access_references] { ::set Collection [[$this $Reference] odb_get]; ::if {$Collection ne ""} { ::set Closure [::qw::union $Closure [[$Collection odb_master] odb_access_closure $sargs]]; } } odb_closure_set .name .access.$UserObjectId .closure $Closure; ::return $Closure; } ::if {[odb_closure_is_set .name .access.all]} { ::return [[odb_master] odb_closure_get .name .access.all]; } # ::if {$User eq ""} {::return "";} ::set Closure [[[$this ".access_froms"] odb_primary] odb_masters]; ::foreach Reference [odb_access_references] { ::set Collection [[$this $Reference] odb_get]; ::if {$Collection ne ""} { ::set Closure [::qw::union $Closure [[$Collection odb_master] odb_access_closure $sargs]]; } } odb_closure_set .name .access.all .closure $Closure; ::return $Closure; } method security_check_is_enabled {} { # if {[odb_user] eq ""} {::return 0;} # return 1; return 0; } # method odb_collision_check {s_args} @qw_odb_master_odb_collision_check; method odb_security_check {s_args} { /* { We get the access closure which is the closure of all access objects belonging to the active user for the upward closure of the master. Then we iterate through the access objects. If any access object does NOT throw an exception then we have access and we simply return. When we catch an exception we check whether it has .priority "security". If so, we move on to the next access object. Otherwise we re-throw the exception. If all of the access objects throw security exceptions then we throw an access denied exception. */ } ::if {![security_check_is_enabled]} {::return;} ::if {![odb_is_created]} {::return;} ::set User [odb_user]; ::if {$User eq ""} {::return;} chain $s_args; ::if {$::qw::control(odb_security_check_access_existence_only)} { /* { If this flag is set then we assume access is denied iff the master has no access objects in the access closure for the current user. Otherwise, i.e. the flag is not set, then we go through the full security check as defined by the access object. */ } ::if {[::llength [odb_access_closure [::sargs .user $User]]]} {::return;} ::set Operation [::sargs::get $s_args .operation]; ::set Object [::sargs::get $s_args .object]; ::qw::throw [::sargs .text "A \"$Operation\" operation was denied on \"[$Object odb_path]\"." .priority security]; } ::foreach Access [odb_access_closure [::sargs .user $User]] { ::qw::try { $Access security_check $s_args; ::return; } catch Exception { ::if {![::sargs::find_field_value .structure $Exception .field ".priority" .value "security"]} { ::qw::throw $Exception; } } } ::set Operation [::sargs::get $s_args .operation]; ::set Object [::sargs::get $s_args .object]; ::qw::throw [::sargs .text "A \"$Operation\" operation was denied on \"[$Object odb_path]\"." .priority security]; } method qw_structure {args} { ::if {[odb_is_remote]} {::return [::eval chain $args];} ::if {![::llength $args]} {::set args "-fields 1 -kids 1"}; ::array set Args $args; ::set Result ""; ::if {[::info exists Args(-fields)]&&$Args(-fields)} {::set Result [::eval chain $args];} ::if {![::info exists Args(-kids)]} {::return $Result;} ::if {!$Args(-kids)} {::return $Result;} #pgq ::set Index [$this ".odb_deriveds.index/id"]; ::if {[::info exists Args(-index)]} {::set Index [$this $Args(-index)];} ::for {::set Reference [$Index odb_first];} {$Reference ne ""} {::set Reference [$Index odb_next $Reference];} { ::set Kid [$Reference odb_master]; # ::set Result [::sargs::set $Result [$Kid odb_id] [::eval $Kid qw_structure $args]]; ::set Script {[$Kid odb_id]}; ::if {[::info exists Args(-script)]} {::set Script $Args(-script);} ::sargs::var::set Result [::subst $Script] [::eval $Kid qw_structure $args]; } return $Result; } method odb_path_backward {} { ::return [path_reverse [odb_path]]; } method odb_path_backward_readable {} { ::return [path_reverse [odb_path_readable]]; } public proc path_reverse {Path} { ::set List1 [::split [::string range $Path 1 end] /]; ::set i [::llength $List1]; ::incr i -1; while {$i>=0} { ::lappend List2 [::lindex $List1 $i]; ::incr i -1; } ::return [::join $List2 /]/; } # method odb_delta {args} @qw_odb_master_odb_delta; # method odb_dependencies_add {s_args} @qw_odb_master_odb_dependencies_add; # method odb_dependencies_update {s_args} @qw_odb_master_odb_dependencies_update; method odb_dependencies_downward {sargs} { ::return [::list]; } /* { method qw_structure {args} { ::if {![::llength $args]} {::set args "-fields 1 -kids 1"}; ::array set Args $args; ::set Result ""; ::if {[::info exists Args(-fields)]&&$Args(-fields)} {::set Result [::eval chain $args];} ::if {![::info exists Args(-kids)]} {::return $Result;} ::if {!$Args(-kids)} {::return $Result;} ::set Index [$this ".odb_deriveds.index/id"]; ::for {::set Reference [$Index odb_first];} {$Reference ne ""} {::set Reference [$Index odb_next $Reference];} { ::set Kid [$Reference odb_master]; ::set Result [::sargs::set $Result [$Kid odb_id] [::eval $Kid qw_structure $args]]; } return $Result; } */ } method daemon_kickout_query {} {::return [odb_kickout_query];} #2.34.0 method odb_kickout_query {} {::return 1;} method odb_idler_commit_query {s_args} {::return 1;} method odb_dump_class_definitions {s_args} { if {![odb_is_class]} { return; } ::set Handle [::sargs::get $s_args .destination_file_handle]; # ::set Meta [odb_meta_get [::sargs .changes 1]]; ::set Meta [odb_meta_get $s_args]; ::if {$Meta ne ""} { ::puts $Handle "class [odb_path]=="; ::puts $Handle [::sargs::format .structure $Meta]; } else { ::puts $Handle "class [odb_path]==empty"; } /* { We use the inetractive index so that the output will be in the same order the classes were originally defined. */ } ::foreach Master [[$this .odb_deriveds.index/interactive] odb_masters [::sargs .order_is_kept 1]] { $Master odb_dump_class_definitions $s_args; } } method odb_base_from_reference {} { ::set Result [[$this .odb_base] odb_get]; ::if {$Result ne ""} { ::set Result [$Result odb_master]; } return $Result; } public proc cpp_ifs_odb_path_help {s_args} { ::set Database [::s_get $s_args .database]; ::set Stuff [$Database cpp_object_structure_load $s_args]; ::set OdbPath [::s_get $Stuff .system.path]; ::set OdbPathReadable [$Database cpp_odb_path_readable $s_args] ::switch -glob -- $OdbPath { /OBJECT/NEWVIEWS/ACCOUNT* { ::return [::string map {/OBJECT/NEWVIEWS {}} $OdbPathReadable]; } /OBJECT/NEWVIEWS/REPORT* { ::return [::string map {/OBJECT/NEWVIEWS {}} $OdbPathReadable]; } /OBJECT/NEWVIEWS/JOURNAL* { ::return [::string map {/OBJECT/NEWVIEWS {}} $OdbPathReadable]; } /OBJECT/NEWVIEWS/PAYROLL* { ::return [::string map {/OBJECT/NEWVIEWS {}} $OdbPathReadable]; } /OBJECT/NEWVIEWS/SYSTEM/TRANSACTION* { ::qw::bug 314120060927020659 "TRANSACTION odb_path_help not implemented yet."; ::if {[::s_get $Stuff .journal] ne ""} { ::return "[[[[$this .journal] qw_get] odb_master] odb_path_help][odb_id_readable]"; } ::if {[[$this ".journal"] qw_get] ne ""} { ::return "[[[[$this .journal] qw_get] odb_master] odb_path_help][odb_id_readable]"; } ::if {[odb_base] ne ""} { ::return "[[odb_base] odb_path_help][odb_id_readable]"; } ::return [chain]; } /OBJECT/NEWVIEWS/SYSTEM/EMPLOYEE* { ::return [::string map {/OBJECT/NEWVIEWS/SYSTEM {}} $OdbPathReadable]; } /OBJECT/NEWVIEWS/SYSTEM/PAYRUN* { ::return [::string map {/OBJECT/NEWVIEWS/SYSTEM {}} $OdbPathReadable]; } /OBJECT/NEWVIEWS/SYSTEM/ROE* { ::return [::string map {/OBJECT/NEWVIEWS/SYSTEM {}} $OdbPathReadable]; } /OBJECT/NEWVIEWS* { ::return [::string map {/OBJECT {}} $OdbPathReadable]; } default { ::return $OdbReadable; ::qw::bug 314120060927014636 "Encountered unexpected path \"$OdbPath\"."; } } } method odb_dependencies_upward_schedule {sargs} { ::switch -exact -- [::sargs::get $sargs .odb_command] { change { } destroy { } default { ::qw::bug 314120071121095701 "Encountered invalid .odb_command \"[::sargs::get $sargs .odb_command]\"."; } } } method count_sandwich_increment {s_args} { /* { This method is called from the constructor/destructor of ::QW::ODB::COUNT_SANDWICH and it incrments/descrements a member variable. */ } ::set Variable [::sargs::get $s_args .variable]; ::set Increment [::sargs::get $s_args .increment]; ::if {$Variable eq ""} { ::qw::bug 314120080212101646 "Encountered invalid variable \"$Variable\"."; } ::if {![::string is integer $Increment]} { ::qw::bug 314120080212101647 "Encountered invalid increment \"$Increment\"."; } ::incr $Variable $Increment; } method odb_changed_field_list {sargs} { ::if {[odb_is_remote]} { ::return [odb_remote_call odb_changed_field_list $sargs]; } ::return [$this cpp_changed_field_list]; } method odb_befores_set {sargs} { # ::set _befores_are_set 1; } /* { method odb_collection_is_enabled {sargs} { ::qw::bug 314120221025093951 "2.36.1 method eliminated"; ::return 1; } */ } method odb_is_new {sargs} { /* { Returns 1 if the object has never been committed before. During the commit process operations can sometimes be made more efficient if we know the object has just been created and has never been committed before. For example, we would know that the references were all empty before and therefore records only need be inserted. */ } ::return [$this cpp_is_new $sargs]; } method odb_get_collection_master {sargs} { ::set FieldPath [::sargs::get $sargs .field_path]; ::if {$FieldPath eq ""} { ::qw::bug 314120160606154149 "[::qw::methodname] - no .field_path argument."; } ::return [[$this $FieldPath] odb_get_collection_master $sargs]; } method qw_get_collection_master {sargs} { ::set FieldPath [::sargs::get $sargs .field_path]; ::if {$FieldPath eq ""} { ::qw::bug 314120160606154150 "[::qw::methodname] - no .field_path argument."; } ::return [[$this $FieldPath] qw_get_collection_master $sargs]; } method odb_debug_structure_get {sargs} { # 2.35.0 ::set Result [$this cpp_odb_master_odb_debug_structure_get $sargs]; ::return $Result; } } # ------------------------------------------------------------ # QW::ODB::ASSIGNABLE class # ------------------------------------------------------------ /* { The primitive types such as strings, numbers, pointers and references are derived from the assignable class. The assignables generally hold a primitive value of some sort and can control their defaults and perform validation checks. They also control signaling when values change. */ } ::qw::itcl::class ::QW::ODB::ASSIGNABLE { inherit ::QW::ODB::OBJECT; method qw_is_null {} {::return [$this cpp_odb_assignable_cpp_is_null];} method qw_get {} {::return [$this cpp_odb_assignable_qw_get];} method qw_set {After} {::return [$this cpp_odb_assignable_qw_set .after $After];} # method qw_set_args {s_args} {::return [$this cpp_odb_assignable_cpp_is_null];} method odb_get {} {::return [$this cpp_odb_assignable_odb_get];} method odb_get_before {} {::return [$this cpp_odb_assignable_odb_get_before];} method qw_get_before {} {::return [$this cpp_odb_assignable_qw_get_before];} method odb_is_defaulted {} {::return [$this cpp_odb_assignable_odb_is_defaulted];} method odb_is_unique {} {::return [$this cpp_odb_assignable_odb_is_unique];} method odb_set_args {sargs} {::return [$this cpp_odb_assignable_odb_set_args $sargs];} method odb_change_before {sargs} {::return [$this cpp_odb_assignable_odb_change_before $sargs];} method odb_change_after {sargs} {::return [$this cpp_odb_assignable_odb_change_after $sargs];} method odb_set_after {After} { ::return [odb_set_args .after $After .change_before_skip 1]; } method odb_security_check {sargs} { chain $sargs; [odb_master] odb_security_check $sargs; } method odb_set {After} { ::return [odb_set_args [::sargs .after $After .change_before_skip 0]]; } method odb_change_before_remote_safe {sargs} { ::if {[odb_is_remote]} { ::return [odb_remote_call odb_change_before $sargs]; } ::return [odb_change_before [::sargs::set $sargs .object $this .field_path [odb_path_from_master]]]; } method odb_changed {s_args} { ::if {[odb_get] ne [odb_get_before]} { ::return 1; } ::return 0; } /* { method qw_structure {args} { ::if {[odb_is_remote]} {::return [::eval chain $args];} ::set Result [::eval chain $args]; #//::puts "20040324 assignable qw_structure args==$args"; ::array set Args $args; ::if {![::info exists Args(-command)]} {::return $Result;} ::switch -- $Args(-command) { "qw_get" {::set Result [::sargs::set $Result .qw_get [qw_get]];} "odb_get" {::set Result [::sargs::set $Result .odb_get [odb_get]];} default {::qw::bug 314120040316152259 "qw_structure did not recognize -command \"$Args(-command)\".";} } ::return $Result; # ::set Result [::sargs::set $Result .qw_get [qw_get]]; # ::set Result [::sargs::set $Result .qw_tcl_get [qw_tcl_get]]; # ::set Result [::sargs::set $Result .odb_get [odb_get]]; # ::set Result [::sargs::set $Result .odb_tcl_get [odb_tcl_get]]; ::return $Result; } */ } method qw_structure {args} { ::if {[odb_is_remote]} {::return [::eval chain $args];} ::set Result [::eval chain $args]; #//::puts "20040324 assignable qw_structure args==$args"; ::array set Args $args; ::if {[::info exists Args(-command)]} { ::switch -- $Args(-command) { "qw_get" {::sargs::var::set Result .qw_get [qw_get];} "odb_get" {::sargs::var::set Result .odb_get [odb_get];} default {::qw::bug 314120040316152259 "qw_structure did not recognize -command \"$Args(-command)\".";} } } ::if {[::info exists Args(-script_field)]} { ::sargs::var::+= Result [::subst $Args(-script_field)]; } ::return $Result; } /* { method qw_structure {args} { ::set Result [::eval chain $args]; ::array set Args $args; ::if {[::info exists Args(-command)]} { ::switch -- $Args(-command) { "copy" { ::return [qw_get]; } } ::qw::bug 314120040316152259 "qw_structure did not recognize -command \"$Args(-command)\"."; } ::return $Result; } */ } method odb_scan {Arg} {::return $Arg;} } # ------------------------------------------------------------ # QW::ODB::STRING class # ------------------------------------------------------------ ::qw::itcl::class ::QW::ODB::STRING { inherit ::QW::ODB::ASSIGNABLE; method odb_boolean_get {} { # 2.34.5 /* { A bunch of calls to USER.options odb_get returned and empty string but the result was immediately tested as a boolean. This seems like a more elegant and grepable way to fix the problem. */ } ::set Result [odb_get]; ::if {$Result eq ""} { ::return 0; } ::return $Result; } } # ------------------------------------------------------------ # QW::ODB::STRUCTURE class # ------------------------------------------------------------ ::qw::itcl::class ::QW::ODB::STRUCTURE { inherit ::QW::ODB::ASSIGNABLE; } # ------------------------------------------------------------ # QW::ODB::STRUCTURE class # ------------------------------------------------------------ ::qw::itcl::class ::QW::ODB::SET { inherit ::QW::ODB::ASSIGNABLE; } # ------------------------------------------------------------ # QW::GUI_WINDOW_RECTANGLE class # ------------------------------------------------------------ ::qw::itcl::class ::QW::GUI_WINDOW_RECTANGLE { /* { The rectangle needs a special class. Stored pixels are converted to inches and loaded inches are converted back to pixels. */ } inherit ::QW::ODB::ASSIGNABLE; } # ------------------------------------------------------------ # QW::ODB::REAL odb_sum IndexPath # ------------------------------------------------------------ /* { If the number is non-null then its value is returned. If the number's outer has subs then there will be corresponding numbers in those subs. Their values are totaled and the result is returned. This is all done recursively. When we encounter a null number whose outer has no subs, we go to specified index and get a number out of its totals. This method is often used within the odb_get of a number (real or integer) to return the sum of numbers from below when the number itself is null. The IndexPath argument identifies the index to use if numbers are retrieved from below the master containing the number. This path is relative to the number field's master so any index in any collection can be used. The index records have any number of totals, but the protocol is to extract the total whose path is the number's path, again relative to its master. That is why it is not necessary to specify the path for the specific total. Note: The rule for a total is to use the field path from the number's master. This protocol is also used by the index definitions so at this point it is global rule for the odb. The method itself is implemented in C++ for maximum speed. */ } # ------------------------------------------------------------ # QW::ODB::NUMBER class # ------------------------------------------------------------ ::qw::itcl::class ::QW::ODB::NUMBER { inherit ::QW::ODB::ASSIGNABLE; method odb_is_summed {} {::return [$this cpp_odb_number_odb_is_summed];} # method odb_sum {IndexPath} @qw_odb_number_odb_sum; # method daemon_sum_pivot {} {::return [odb_sum_pivot];} # method daemon_sum_super {} {::return [odb_sum_super];} method odb_sum_pivot {} {::qw::throw "The sum pivot for [odb_path] was not specified.";} method odb_sum_super {} {::return "";} /* { method odb_set_args {After s_args} { ::if {[odb_is_summed]} { puts "NUMBER::odb_set_args,odb_path==[odb_path],After==$After,s_args==$s_args" } chain $After $s_args; } */ } method odb_scan {Arg} { ::qw::bug 314120040111095551 "QW::ODB::NUMBER::odb_scan was not overridden."; } } # ------------------------------------------------------------ # QW::ODB::REAL class # ------------------------------------------------------------ ::qw::itcl::class ::QW::ODB::REAL { inherit ::QW::ODB::NUMBER; method odb_scan {Arg} {::return [::qw::real::scan $Arg];} method qw_structure {args} { ::if {[odb_is_remote]} { ::return [::eval chain $args]; } ::set Result [::eval chain $args]; ::if {![::info exists Args(-command)]} { ::return $Result; } ::if {[qw_get] eq "0.0"} { ::set Result [::sargs::set $Result .qw_get ""]; } else { ::set Result [::sargs::set $Result .qw_get [qw_get]]; } return $Result; } /* { method qw_structure {args} { ::set Result [::eval chain $args]; ::if {[qw_get] eq "0.0"} { ::set Result [::sargs::set $Result .qw_get ""]; } else { ::set Result [::sargs::set $Result .qw_get [qw_get]]; } return $Result; } */ } /* { method qw_structure {args} { ::set Result [::eval chain $args]; ::array set Args $args; ::if {[::info exists Args(-command)]} { ::switch -- $Args(-command) { "copy" { ::return [qw_get]; } } ::qw::bug 314120040316152259 "qw_structure did not recognize -command \"$Args(-command)\"."; } ::return $Result; } */ } /* { method qw_structure {args} { ::set Result [::eval chain $args]; ::array set Args $args; ::if {[::info exists Args(-command)]} { ::switch -- $Args(-command) { "copy" { ::set Result [::eval chain $args]; ::if {$Result eq "0.0"} {::return "";} ::return $Result; } } ::qw::bug 314120040316153007 "qw_structure did not recognize -command \"$Args(-command)\"."; } ::return $Result; } */ } } # ------------------------------------------------------------ # QW::ODB::INTEGER class # ------------------------------------------------------------ ::qw::itcl::class ::QW::ODB::INTEGER { inherit ::QW::ODB::NUMBER; method qw_structure {args} { ::if {[odb_is_remote]} { ::return [::eval chain $args]; } ::set Result [::eval chain $args]; ::if {![::info exists Args(-command)]} { ::return $Result; } ::if {[qw_get] eq "0"} { ::set Result [::sargs::set $Result .qw_get [qw_get]]; } else { ::set Result [::sargs::set $Result .qw_get ""]; } return $Result; } /* { method qw_structure {args} { ::set Result [::eval chain $args]; ::if {[qw_get] eq "0"} { ::set Result [::sargs::set $Result .qw_get [qw_get]]; } else { ::set Result [::sargs::set $Result .qw_get ""]; } return $Result; } */ } /* { method qw_structure {args} { ::set Result [::eval chain $args]; ::array set Args $args; ::if {[::info exists Args(-command)]} { ::switch -- $Args(-command) { "copy" { ::set Result [::eval chain $args]; ::if {$Result eq "0"} {::return "";} ::return $Result; } } ::qw::bug 314120040316153054 "qw_structure did not recognize -command \"$Args(-command)\"."; } ::return $Result; } */ } /* { method odb_get {} { ::set Result [chain]; ::if {$Result eq ""} {::return $Result;} ::return [::expr {int($Result)}]; } */ } /* { method odb_tcl _get {} { ::set Value [chain]; ::if {$Value eq ""} {::return 0;} ::return $Value; } method odb_tcl_set {After} { ::if {$After eq ""} {::set After 0;} ::return [chain $After]; } */ } method odb_scan {Arg} {::return [::qw::integer::scan $Arg];} } ::qw::itcl::class ::QW::ODB::DATE { inherit ::QW::ODB::ASSIGNABLE; method odb_scan {Arg} { ::return [::qw::date::scan $Arg]; } #nv2.27.3 (bug fix) - CRM and time card .time_start and .time_end must be synchronized with the .date method gui_odb_set {Src} { # A 'translation' slice for setting a date using the user's specified .option.date.entry #//::puts "pgq,debug313::QW::ODB::DATE gui_odb_set field odb_path_from_master==[odb_path_from_master] Src==$Src"; /* { Let the odb_sets do the work on handling remote. This problem cost 2 days in 2.27.3 because defaults were not being set properly for dates */ } #::if {[odb_is_remote]} { # ::return [odb_remote_call gui_odb_set $Src]; #} ::switch -glob -- [odb_path_from_master] { .time* { # NOTICE - format from edit_assist dialog::time /* { timeentry,result==20140415170331 timeentry,result==20140415170000 timeentry,result== timeentry,result==20140415235959 .../TABLE.client edit_assist_item ::qw::dialog::timeentry Result==20140610141633 .../TABLE.client edit_assist_item ::qw::dialog::timeentry Result==20140610211706 */} ::set After [::string tolower [::string trim $Src]]; #//::puts "pgq,debug313::QW::ODB::DATE gui_odb_set 000 After==$After"; # NOTICE - escape to edit_assist_item .type time will return WITHOUT performing a table cell set, meaning this method is not called ::set MaybeFromDialog [::regsub -all {[^0-9.]} $After ""]; #//::puts "pgq,debug313::QW::ODB::DATE gui_odb_set MaybeFromDialog==$MaybeFromDialog"; ::if {[::string length $MaybeFromDialog]==14} { #::set After "[::string range $After 8 9]:[::string range $After 10 11]:[::string range $After 12 13]"; ::set After "[::string range $MaybeFromDialog 8 9]:[::string range $MaybeFromDialog 10 11]:[::string range $MaybeFromDialog 12 13]"; } #//::puts "pgq,debug313::QW::ODB::DATE gui_odb_set 111 After==$After"; ::switch -glob -- $After { "" { ::return [odb_set ""]; } "n*" - "t*" { ::set After [[odb_master] server_clock_seconds_formatted]; ::set After "[::string range $After 8 9]:[::string range $After 10 11]:[::string range $After 12 13]"; } } #//::puts "pgq,debug313::QW::ODB::DATE gui_odb_set 222 After==$After"; ::set Date [[[odb_master] .date] odb_get]; # NOTICE - scan will put today's date at the front, if After is not empty and it scans ::set Scan [::qw::date::scan $After]; #//::puts "pgq,debug313::QW::ODB::DATE gui_odb_set After==$After Scan==$Scan Date==$Date"; ::if {$Date ne ""} { ::set After "[::string range $Date 0 7][::string range $Scan 8 end]"; } else { ::set After $Scan; } #//::puts "pgq,debug313::QW::ODB::DATE gui_odb_set 333 After==$After"; ::return [odb_set $After]; } default { ::return [odb_set [::qw::date::gui_edit [odb_get] $Src [date_entry_option]]]; } } } #nv2.27.3 (bug fix) - CRM and time card .time_start and .time_end must be synchronized with the .date public method odb_change_after {s_args} { #//::puts "pgq,debug::QW::ODB::DATE odb_change_after enter s_args==(\n[::sargs::format .structure $s_args]\n)"; ::set After [::sargs::get $s_args .after]; ::if {$After eq ""} { ::return [chain $s_args]; } ::switch -glob -- [odb_path_from_master] { .time* { /* { .time_start or .time_end has just been set to value After. If we are in a transaction header and the date is empty, we set the date to After as well. This broke transaction create duplicate and potentially also transaction create post-dated. They were fixed in 2.27.4 by skipping them when duplicating. */ } ::set Date [[[odb_master] .date] odb_get]; ::if {$Date eq ""&&[[[odb_master] .journal] qw_get] ne ""} { [[odb_master] .date] odb_set [::string range $After 0 7]; } } } chain $s_args; } method gui_odb_set_extend_begin {Src} { #nv2.26.1a (bug fix) - ::qw::date::extend_begin and ::qw::date::extend_end - they do not touch already extended dates (e.g. ::qw::date::extend_end 20130913000000 == 20130913000000) #::return [odb_set [::qw::date::extend_begin [::qw::date::gui_edit [odb_get] $Src [date_entry_option]]]]; ::return [odb_set [::qw::date::extend_begin [::string range [::qw::date::gui_edit [odb_get] $Src [date_entry_option]] 0 7]]]; } method gui_odb_set_extend_end {Src} { #//::puts "pgq,debug602...gui_odb_set_extend_end Src==$Src"; #//::puts "pgq,debug602...gui_odb_set_extend_end Src==$Src odb_get==[odb_get]"; #//::puts "pgq,debug602...gui_odb_set_extend_end Src==$Src gui_edit==[::qw::date::gui_edit [odb_get] $Src [date_entry_option]]"; #//::puts "pgq,debug602...gui_odb_set_extend_end Src==$Src odb_set=[::qw::date::extend_end [::qw::date::gui_edit [odb_get] $Src [date_entry_option]]]"; # NOTICE #// gui_edit - calls ::qw::date::scan - which calls ::qw::date::from_number seconds $Seconds - which "extends" to the begin #// e.g. "13 Sep 2013" returns "20130913000000" #nv2.26.1a (bug fix) - ::qw::date::extend_begin and ::qw::date::extend_end - they do not touch already extended dates (e.g. ::qw::date::extend_end 20130913000000 == 20130913000000) #::return [odb_set [::qw::date::extend_end [::qw::date::gui_edit [odb_get] $Src [date_entry_option]]]]; ::return [odb_set [::qw::date::extend_end [::string range [::qw::date::gui_edit [odb_get] $Src [date_entry_option]] 0 7]]]; } method date_entry_option {} { #::set User [odb_user]; ::set User [[odb_database application] cpp_user_get]; ::if {$User eq ""} {::return "scan";} ::return [[$User ".options.date.entry"] odb_get]; } /* { method gui_odb_set {Src} { # A 'translation' slice for setting a date using the # user's specified .option.date.entry (with some added tricks.) # ::if {$Src eq ""} {::return [odb_set $Src];} # ::set Letter ""; ::if {[::regexp {(^[+|-])([0-9]+(D|W|M|Y)*$)} [::string toupper $Src] match Sign Number Letter]} { # Src== "+/-#X" # +/- Sign - Increment/decrement the date # # Integer - units to increment/decrement # X Duration; "" and "D"==day, "W"==week, "M"==month, "Y"==year (case insensitive) ::switch -- $Letter { "" - "D" {::return [odb_set [::qw::date::add [odb_get] "day" $Sign$Number]];} "W" {::return [odb_set [::qw::date::add [odb_get] "day" ${Sign}7]];} "M" {::return [odb_set [::qw::date::add [odb_get] "month" $Sign$Number]];} "Y" {::return [odb_set [::qw::date::add [odb_get] "year" $Sign$Number]];} default {::return [odb_set [::qw::date::add [odb_get] "day" $Sign$Number]];} } } #::set User [odb_user]; ::set User [[odb_database application] cpp_user_get]; ::if {$User eq ""} {::return [odb_set [::qw::date::scan $Src]];} ::set DateEntryOption [[$User ".options.date.entry"] odb_get]; ::if {$DateEntryOption eq "default"} { ::return [odb_set [::qw::date::scan $Src]]; } ::if {$DateEntryOption eq "ddmmyyyy"} { ::if {[::regexp {^([0-9]+)$} [::string trim $Src]]&&[::string length $Src]<=8} { # Src is <= 8 chars, all digits ::return [odb_set [::qw::date::dos_edit $Src [odb_get]]]; } ::return [odb_set [::qw::date::scan $Src]]; } ::qw::throw "Encountered unknown date entry format \"$DateEntryOption\"."; } */ } } # ------------------------------------------------------------ # QW::ODB::POINTER class # ------------------------------------------------------------ ::qw::itcl::class ::QW::ODB::POINTER { inherit ::QW::ODB::ASSIGNABLE; method odb_change_before {s_args} { /* { # 2.22.0 This check was added to ensure that a pointer in an application database cannot point to an object in a different (i.e. external) database. */ } chain $s_args ::set After [::sargs::get $s_args .after]; ::if {$After ne ""} { ::if {[[odb_database] cpp_database_type_get] eq "application"} { ::set DatabaseId [[odb_database] cpp_database_id_get]; ::set AfterDatabaseId [::qw::odb::database_id_extract .address $After]; ::if {$AfterDatabaseId ne $DatabaseId} { ::qw::throw \ .text "You cannot point to an object in a different database." \ .help_id ??? \ ; } } } } } # ------------------------------------------------------------ # QW::ODB::REFERENCE class # ------------------------------------------------------------ ::qw::itcl::class ::QW::ODB::REFERENCE { inherit ::QW::ODB::ASSIGNABLE; # method -> {} {::return [odb_get];} method odb_change_before {s_args} { chain $s_args ::if {[::sargs::get $s_args .before] ne ""} { ::sargs::var::set s_args .reference $this; ::foreach Address [[::sargs::get $s_args .before] odb_closure] { [[odb_database] cpp_load $Address] odb_change_before $s_args; } } ::if {[::sargs::get $s_args .after] ne ""} { ::sargs::var::set s_args .reference $this; ::foreach Address [[::sargs::get $s_args .after] odb_closure] { [[odb_database] cpp_load $Address] odb_change_before $s_args; } } return $this; } method odb_change_after {sargs} { chain $sargs # speedup - I think we can remove this stuff. ::set Before [::sargs::get $sargs .before]; ::if {$Before ne ""} { ::sargs::var::set sargs .reference $this; ::foreach Collection [$Before odb_closure] { $Collection odb_change_after $sargs; } } ::set After [::sargs::get $sargs .after]; ::if {$After ne ""} { ::sargs::var::set sargs .reference $this; ::foreach Collection [$After odb_closure] { $Collection odb_change_after $sargs; } } return $this; } method odb_destroy_before {sargs} { chain $sargs; ::set Before [qw_get]; ::if {$Before ne ""} { ::sargs::var::set sargs .reference $this; ::foreach Address [$Before odb_closure] { ::sargs::var::set sargs .before $Before; [[odb_database] cpp_load $Address] odb_change_before $sargs; } } return $this; } method qw_structure {args} { ::if {[odb_is_remote]} {::return [::eval chain $args];} ::set Result [::eval chain $args]; ::array set Args $args; ::if {![::info exists Args(-closure)]} {::return $Result;} ::if {!$Args(-closure)} {::return $Result;} ::if {[odb_get] ne ""} { ::set Result [::sargs::set $Result "" [::eval [[odb_get] odb_master] qw_structure $args]]; } return $Result; } /* { method qw_structure {args} { ::set Result [::eval chain $args]; ::array set Args $args; ::if {[::info exists Args(-command)]} { ::switch -- $Args(-command) { "copy" { ::return [::eval chain $args]; } } ::qw::bug 314120040316155119 "qw_structure did not recognize -command \"$Args(-command)\"."; } ::if {![::info exists Args(-closure)]} {::return $Result;} ::if {!$Args(-closure)} {::return $Result;} ::if {[odb_get] ne ""} { ::set Result [::sargs::set $Result "" [::eval [[odb_get] odb_master] qw_structure $args]]; } return $Result; } */ } method odb_get_collection_master {sargs} { ::set Collection [odb_get]; ::if {$Collection ne ""} { ::return [$Collection odb_master]; } ::return ""; } method qw_get_collection_master {sargs} { ::set Collection [qw_get]; ::if {$Collection ne ""} { ::return [$Collection odb_master]; } ::return ""; } } ::qw::itcl::class ::QW::ODB::COLLECTION { # ------------------------------------------------------------ # QW::ODB::COLLECTION class # ------------------------------------------------------------ inherit ::QW::ODB::FIELD; method odb_primary {} { ::qw::bug 314120060320104831 "The primary index for collection [odb_path] has not been specified."; } method odb_items {} { ::return [[odb_primary] odb_items]; } method odb_total {Path} {::return [[odb_primary] odb_total $Path];} method odb_factory_reference {args} { ::if {[odb_is_remote]} { ::return [::eval odb_remote_call odb_factory_reference $args]; } ::qw::throw "Attempted to create a new object using \"[odb_path_readable]\"."; } method odb_factory {args} { ::if {[odb_is_remote]} { ::return [::eval odb_remote_call odb_factory $args]; } ::qw::try { [odb_master] odb_security_check ".object $this .operation create"; ::set s_args ""; ::foreach {Name Value} $args { ::sargs::var::set s_args [::string replace $Name 0 0 .] $Value; } ::if {![::sargs::exists $s_args .odb_create_before]} { ::sargs::var::set s_args .odb_create_before 1; } ::if {[::sargs::get $s_args .odb_create_before]} { odb_create_before $s_args; } ::set Object [::eval odb_factory_this $args]; } catch Exception { ::qw::throw [::qw::exception::parent $Exception [::sargs \ .text "Could not create an object using collection \"[odb_path_readable]\"." \ .help_id 314120050223094019 \ ]]; } odb_create_after [::sargs::set $s_args .object $Object]; return $Object; } method odb_factory_this {args} { ::qw::throw "Collection [odb_path] cannot be used to create objects."; } method odb_create_before {sargs} { [odb_master] odb_change_before [::sargs::set $sargs .object $this .field_path [odb_path_from_master]]; } method odb_create_after {sargs} {} method odb_destroy_kids {sargs} { /* { We cannot use odb_masters here, at least not if we are a window. In the case of a window, when we destroy one kid, other kids may wake up, be gui loaded, and connect to our collection. Therefore we have to keep destroying kids until there are none left. Perhaps we can use odb_masters for non-windows. */ } ::set Index [odb_primary]; ::set Progress ""; ::set ProgressMinimum 10; ::if {[::string first "/OBJECT/NEWVIEWS/SYSTEM/TRANSACTION" [odb_path]]==0} { /* { 2.35.1 - too much noise deleting transaction details when deleting all or a block of transaction headers such as when running delete_transactions_asynch.qw_script. */ } ::set ProgressMinimum 100; } ::set ProgressLimit [$Index odb_items]; ::if {$ProgressLimit>=$ProgressMinimum} { ::set Progress [::itcl::local ::QW::PROGRESS::OPERATION #auto \ .database_id [[odb_database] cpp_database_id_get] \ .file [[odb_database] cpp_database_path] \ .user [odb_user_name] \ .limit $ProgressLimit \ .operation "Deleting descendants" \ .status "[[odb_database] cpp_database_path] deleting $ProgressLimit descendant objects." \ ]; } ::while {[$Index odb_last] ne ""} { ::set Reference [$Index odb_last]; ::if {[[odb_database] cpp_find_from_address $Reference] ne ""} { [$Reference odb_master] odb_destroy $sargs; } ::if {$Progress ne ""} {$Progress increment;} } } method odb_closure {sargs} { ::set Closure $this; ::set Base [odb_base]; ::if {$Base ne ""} { ::set Closure [::qw::union $Closure [$Base odb_closure $sargs]]; } ::return $Closure; } method odb_change_before {s_args} { /* { This method receives .reference in addition to .before and .after. */ } # [odb_master] odb_signal_send ".command odb_change_before"; odb_signal_send [::sargs::set $s_args .command odb_change_before]; } method odb_change_after {s_args} { /* { This method receives -reference in addition to -before and -after. */ } #::return; /* { No one ever repsonded to a collection odb_change_after signal_send in the past and then we added the response in the gui when we added the window list buttons. But it produced general protection faults. It's complicated. But if we limitied the signals to the clipper.kids collection we seemed to work. */ } if {[::string first [odb_path] ".clipper.kids"]>=0} { odb_signal_send [::sargs::set $s_args .command odb_change_after]; } # [odb_master] odb_signal_send ".command odb_change_after"; } method odb_destroy_before {sargs} { ::if {[odb_is_window]} { /* { Kludge alert. */ } ::return; } chain $sargs; ::if {[::string first /OBJECT/NEWVIEWS/SYSTEM/TRANSACTION/PAYROLL/PAYCHECK [odb_path]]==0} { ::if {[odb_id] eq ".timecards"} { ::return; } } ::set Index [odb_primary]; ::sargs::var::set sargs .security_check_skip 1; ::for {::set Ref [$Index odb_first];} {$Ref ne ""} {::set Ref [$Index odb_next $Ref];} { [$Ref odb_master] odb_destroy_before $sargs; } } method odb_amounts_paths {} {::return [$this cpp_odb_collection_odb_amounts_paths];} method odb_closure_before {sargs} {::return [$this cpp_odb_collection_odb_closure_before $sargs];} method odb_amounts_paths_select {s_args} { /* { Traverses a structure and returns a list of paths with an element for each field that has a .get field. Note that we did not use the ::qw::structure:select method since it traverses all fields. We can increase speed by not diving down further when a field is selected. */ } ::set Structure [::sargs::get $s_args .structure]; ::set Parent [::sargs::get $s_args .parent]; ::set Name [::sargs::get $s_args .name]; ::if {[::sargs::exists $Structure .get]} {::return $Parent$Name;} ::set Result ""; ::foreach KidName [::sargs::names .structure $Structure] { ::set KidPaths [odb_amounts_paths_select [::sargs .parent $Parent$Name .name $KidName .structure [::sargs::get $Structure $KidName]]]; ::foreach KidPath $KidPaths {::lappend Result $KidPath;} } return $Result; } method odb_schema {} { /* { Returns the amounts schema structure. Here, in the root collection class, we return the definition of the count so that every index in every collection can provide a "line number". */ } ::return { .count { .description "Line Number or Count" .help {} .get 1 } } } /* { method odb_is_gatgun {} { ::return 0; } method odb_has_tags {} { #2.36.0 ::return [odb_is_gatgun]; } */ } method odb_is_gatgun {} { ::return [odb_has_tags]; } method odb_has_tags {} { #2.36.0 ::return 0; } /* { method odb_has_tags {} { #2.37.0 ::return 0; } */ } method index_signaling_is_enabled {} { /* { This is a test. The transaction has odb_is_summed fields that rely on the odb_deriveds indexes. We can later formalize this by testing whether any fields in the object are summed. We will also make it more efficient. For example, a meta flag can be set in the collection whenever a summed field is introduced. By note that just because a field is summed does not actually mean it is used in an index. */ } ::return 0; } method odb_amounts_build {sargs} {::return [$this cpp_odb_collection_odb_amounts_build $sargs];} method odb_collection_is_enabled {} {::return 1;} method odb_collection_enable_populate_id_index {sargs} { /* { When a collection becomes enabled we populate it's COLLECTION.index/id index by recorsively copying records from enabled collections below. Although this could be done right here, (and originally was), we instead perform the copy at low-level. This is in keeping with movement of all active index code to low-level. This works in general but currently only applies to ACCOUNT.postings and JOURNAL.transactions. When the collection is disabled, all indexes including .index/id are mage inactive. When the collection becomes enabled, we populate the .index/id index by recursively gathering the records from below, .odb_deriveds.index/id for .transactions, or .total.kids.index/id for .postings. We only dive down until we hit an enabled collection. Whenever we visit an enabled collection we copy it's ,index/id index to the root. We dive no further under an enabled collection. Note: We are using a switch in the base method instead of using overriding methods in JOURNAL.transactions and ACCOUNT.postings. This is not a "good" programming practise but keeps everything in one place. */ } ::if {!$::qw::control(active_index_is_enabled)} { ::qw::bug 314120241119104218 "[::qw::methodname] - invalid method call."; } ::switch -glob -- [odb_path] { /OBJECT/NEWVIEWS/ACCOUNT*.postings { ::qw::odb::active_index::collection_enable_populate_postings_index_id \ .database [odb_database] \ .root_account $this \ ; ::return; } /OBJECT/NEWVIEWS/JOURNAL*.transactions { ::qw::odb::active_index::collection_enable_populate_transactions_index_id \ .database [odb_database] \ .root_journal $this \ ; ::return; } default { ::qw::bug 314120221027161413 "[::qw::methodname] - invalid collection \"$this\"."; } } } } # ------------------------------------------------------------ # QW::ODB::INDEX class # ------------------------------------------------------------ /* { This is the ultimate base class for all index classes. Whenever you introduce a new index field you specify its corresponding itcl class, which we will its "daeman" class. The class described here should be the utlimate ancestor for all index daeman classes. Aside: All index daeman classes do not in fact have to be derived from class as long as they specify the required daeman methods. However, it is unlikely that doing so serves any useful purpose. This class introduces default behavior. The default behaviour is generally to call the same method on the super, if any, and to return a "reasonable" result or take "reasonable" action it there is no super. This default behaviour is described below for each required daeman method. This class also serves as the ancestor of the root index. The root index is the index in an index sub-tree that has no super. An method of the root index of course does not call its super's corresponding method because it has no super. daemon_isHit {Reference} ---------------------- The daemon_isHit method returns "1" if the reference should be inserted in the index and returns "0" otherwise. The default is to call the daemon_isHit method on the super and to return true if there is no super. If a sub-index does not override this beaviour, and no supers up to the root of the index super tree overrides the method, then true is returned. daemon_key {Reference} -------------------------------- The daemon_key method returns the key. The root index class puts the index master handle to the key. This allows each index class and its instances to share the same ifs file for the index. Each is "noded" by the index master handle within the file. Every daemon_key should chanin first. The it appends additional key components. daemon_record_amounts {Reference Amounts} -------------------------------- When any index in the hierarchy is introduced, i.e. not derived from another user-defined index, this is deemed its heritage parent in the itcl class hierarchy. odb_totals {Reference} ---------------------- Returns totals for the index. The totals are returned as a list of name/value pairs suitable for manipulation using a tcl array. If reference is not specified then the totals for the entire index are returned. If reference is specified then the totals corresponding to the reference are returned. This is done by asking the reference to produce a key, and then returning the totals corrsponding to that key as the result of a seek on the file. Note that the record sought might not exist as the reference might not be a hit in the index. */ } ::qw::itcl::class ::QW::ODB::INDEX { inherit ::QW::ODB::FIELD; method odb_items {} {::return [$this cpp_odb_index_odb_record_count];} method odb_total {sargs} {::return [$this cpp_odb_index_odb_total $sargs];} method odb_is_interactive {} {::return [$this cpp_odb_index_odb_is_interactive];} method odb_is_enabled {} {::return [$this cpp_odb_index_odb_is_enabled];} method odb_first {} {::return [$this cpp_odb_index_odb_first];} method odb_last {} {::return [$this cpp_odb_index_odb_last];} method odb_next {Reference} {::return [$this cpp_odb_index_odb_next .reference $Reference];} method odb_prev {Reference} {::return [$this cpp_odb_index_odb_prev .reference $Reference];} method odb_make_first {Reference {RecordCount 1}} {::return [$this cpp_odb_index_odb_make_first .reference $Reference .record_count $RecordCount];} method odb_make_last {Reference {RecordCount 1}} {::return [$this cpp_odb_index_odb_make_last .reference $Reference .record_count $RecordCount];} method odb_make_before {Reference Destination {RecordCount 1}} {::return [$this cpp_odb_index_odb_make_before .reference $Reference .destination $Destination .record_count $RecordCount];} method odb_make_after {Reference Destination {RecordCount 1}} {::return [$this cpp_odb_index_odb_make_after .reference $Reference .destination $Destination .record_count $RecordCount];} # method odb_destroy_kids {s_args} @qw_odb_index_odb_destroy_kids; method odb_key_from_components {args} {::return [$this cpp_odb_index_odb_key_from_components .key $args];} method odb_seek_key {args} {::return [$this cpp_odb_index_odb_seek_key .key $args];} method odb_seek_key_go_item {args} {::return [$this cpp_odb_index_odb_seek_key_go_item .key $args];} method odb_find_key {args} {::return [$this cpp_odb_index_odb_find_key .key $args];} method odb_seek_count {Count} {::return [$this cpp_odb_index_odb_seek_count .count $Count];} method odb_find_key_unique {args} {::return [$this cpp_odb_index_odb_find_key_unique .key $args];} method odb_masters {sargs} {::return [$this cpp_odb_index_odb_masters $sargs];} method odb_references {sargs} {::return [$this cpp_odb_index_odb_references $sargs];} method odb_last_key_components {sargs} {::return [$this cpp_odb_index_last_key_components $sargs];} method odb_collection {sargs} {::return [$this cpp_odb_index_odb_collection];} method odb_schema {} { /* { Returns the full index definition as a structure. The components of the index are defined as the inners of the .key field. The .is_hit field takes and uses a local Reference variable and returns 1 or 0 indicating whether the reference is a hit. The default behavior defined here is to return 1 unless we are the root index, i.e. .index itself. So unless you replace this method, indexes you introduce will default to always being hits. The .is_interactive returns 0 or 1. It defaults to 0 so it must be overridden for any interactive indexes. It takes no arguments. */ } ::return { .key {} .is_hit {[ ::if {[odb_super] eq ""} {::return 0;} ::return 1; ]} .is_interactive 0 .is_closure 0 .active_index { .key { ::qw::bug 314120250530081637 "Active index key proc was not overridden."; } .is_hit { /* { We are given ObjectStructure and IndexField */ } ::if {[::file extension $IndexField ".index"] eq ".index"} { ::return 0; } ::return 1; } .is_interactive { ::return 0; } .is_closure { ::return 0; } } }; } method schema_key {} { return [::sargs::get [odb_schema] .key]; } method odb_is_closure {} { # 2.34.11 return [$this cpp_odb_index_odb_is_closure]; } method odb_active_index_is_active {} { ::set Result [$this cpp_odb_index_odb_active_index_is_active]; ::return $Result; } method odb_active_index_make_active {sargs} { $this cpp_odb_index_odb_active_index_make_active $sargs; } method odb_active_index_make_inactive {} { $this cpp_odb_index_odb_active_index_make_inactive; } } ::namespace eval ::qw::odb {} ::namespace eval ::qw::odb::index {} /* { The next few index procs are convenience procs where many different indexes share the same schema. */ } ::proc ::qw::odb::index::id {} { ::return { .key { .id { .type string .description {::return "master id"} .help {} .get {[[$Reference odb_master] odb_id]} } } } } ::proc ::qw::odb::index::name {} { ::return { .key { .name { .type string .description {::return "Name"} .help {} .get {[[[$Reference odb_master] ".name"] odb_get]} } } } } ::proc ::qw::odb::index::description {} { ::set Result { .key { .description { .type string .description {::return "Description"} .help {} .get {[[[$Reference odb_master] ".description"] odb_get]} } } } ::return "$Result [::qw::odb::index::name]" } ::proc ::qw::odb::index::date {} { ::return { .key { .date { .type date .description {::return "Date"} .help {} .get {[[[$Reference odb_master] ".date"] odb_get]} } } } } ::proc ::qw::odb::index::interactive {} { ::return { .is_interactive 1 }; }