# ------------------------------------------------------------ # Copyright (c) 2009 - 2014 # Q.W.Page Associates Inc. # www.qwpage.com # All rights reserved. # ------------------------------------------------------------ ::itcl::class ::qw::odb2::object_structure_manager { /* { Object structures are stored in the array _object_structures_by_object_id. The _object_structures_by_path value is an object_id for an indirect lookup. _metas are stored by class_path. The value is the full meta after plus equal recursively with base classes. If you want the raw meta get the object structure and extract it. Also, you can ask for a meta by object id but it is ultimately extracted from the meta by path. */ } protected variable _sargs ""; protected variable _database ""; protected variable _database_id ""; protected variable _database_path ""; protected variable _database_type ""; protected variable _user ""; protected variable _username ""; protected variable _object_structures_by_object_id; # index==object_id,value==object_structure protected variable _object_structures_by_object_path; # index==path,value==object_id # protected variable _metas_by_object_id; # index==object_id,value==object_structure protected variable _metas_by_class_path; protected variable _reference_field_lists_by_class_path; protected variable _pointer_field_lists_by_class_path; # 2.22.1 protected variable _indirect_field_lists_by_class_path; # 2.23.0 protected variable _collection_index_field_lists_by_class_path_collection_field; # 2.25.0 protected variable _tag_list [::list]; # 2.25.0 protected variable _down_closure_list [::list]; # temporary used by down_closure_list method protected variable _down_closure_array; # temporary used by down_closure_list method protected variable _cache_disabled 0; method constructor {sargs} { ::array set _object_structures_by_object_id {}; ::array set _object_structures_by_object_path {}; # ::array set _metas_by_object_id {}; ::array set _metas_by_class_path {}; ::array set _reference_field_lists_by_class_path {}; ::array set _pointer_field_lists_by_class_path {}; ::array set _indirect_field_lists_by_class_path {}; ::array set _collection_index_field_lists_by_class_path_collection_field {}; ::set _sargs $sargs; ::set _database [::sargs::get $sargs .database]; ::if {$_database eq ""} { ::qw::bug 314120090128141434 "Encountered empty \".database\" argument."; } ::set _database_id [$_database cpp_database_id_get]; ::set _database_path [$_database cpp_database_path]; ::set _database_type [$_database cpp_database_type_get]; ::set _user [$_database cpp_user_get]; ::if {$_user ne ""} { ::set _username [[$_user .name] odb_get]; } ::set _cache_disabled [::sargs::boolean_get $sargs .cache_disabled]; } destructor { } method database {} { ::return $_database; } method object_structure_cache_clear {} { # ::qw::dialog3::notify .text "About to clear object_structure_manager object cache"; ::array unset _object_structures_by_object_id *; ::array unset _object_structures_by_object_path *; # ::qw::dialog3::notify .text "Cleared in $Milli milliseconds."; } method object_structure_find {sargs} { /* { Returns an object structure. Priority of arguments: .object_id .address .path .name_list */ } ::set ObjectId [::sargs::get $sargs .object_id]; ::if {$ObjectId ne ""} { ::if {![::info exists _object_structures_by_object_id($ObjectId)]} { ::set OS [$_database cpp_object_structure_find $sargs]; ::if {[::sargs::size $OS]==0} { ::return ""; } ::set Path [::sargs::get $OS .system.path]; ::set ClassPath [::sargs::get $OS .system.class_path]; ::switch -glob -- $Path { /OBJECT/NEWVIEWS/ACCOUNT* { ::set KidsCount [$_database cpp_file_record_count \ .path /odb/index${ClassPath}.total.kids.index/name \ .range.begin [::list string $ObjectId] \ .range.end [::list string $ObjectId] \ ]; ::sargs::var::set OS .application.total.kids.record_count $KidsCount; } default { } } ::if {!$_cache_disabled} { ::set _object_structures_by_object_id($ObjectId) $OS; ::set _object_structures_by_object_path($Path) $ObjectId; } ::return $OS; } ::return $_object_structures_by_object_id($ObjectId); } ::set Address [::sargs::get $sargs .address]; ::if {$Address ne ""} { ::return [[::qw::methodname] .object_id [::qw::odb::object_id_extract .address $Address]]; } ::set Path [::sargs::get $sargs .path]; ::if {$Path ne ""} { ::if {[::info exists _object_structures_by_object_path($Path)]} { ::return [[::qw::methodname] .object_id $_object_structures_by_object_path($Path)]; } ::set OS [$_database cpp_object_structure_find $sargs]; ::if {[::sargs::size $OS]==0} { ::return ""; } ::set ObjectId [::sargs::get $OS .system.object_id]; ::return [[::qw::methodname] .object_id $ObjectId]; } ::set NameList [::sargs::get $sargs .name_list]; ::if {[::llength $NameList]!=0} { ::set OS [$_database cpp_object_structure_find $sargs]; ::if {[::sargs::size $OS]==0} { ::return ""; } ::set ObjectId [::sargs::get $OS .system.object_id]; ::return [[::qw::methodname] .object_id $ObjectId]; } ::qw::bug 314120090128141243 "[::qw::methodname] - invalid arguments \"$sargs\"."; } method object_structure_exists {sargs} { /* { Returns an object structure. Priority of argauments: .object_id .address .path */ } ::set OS [object_structure_find $sargs]; ::if {[::sargs::size $OS]==0} { ::return 0; } ::return 1; } method object_structure_load {sargs} { ::set OS [object_structure_find $sargs]; ::if {[::sargs::size $OS]==0} { ::qw::bug 314120091022164027 "[::qw::methodname] - can't load \"$sargs\"."; } ::return $OS; } method indirect_fields_load {sargs} { #2.26.0 /* { Given a Usage: $_osm indirect_fields_load .os $OS; or anything used by .object_structure_load; */ } ::set OS [::sargs::get $sargs .os]; ::if {[::sargs::size $OS]==0} { ::set OS [object_structure_find $sargs]; ::if {[::sargs::size $OS]==0} { ::qw::bug 314120130405141037 "[::qw::methodname] - can't load \"$sargs\"."; } } ::set ObjectId [::sargs::get $OS .system.object_id]; ::set ClassPath [::sargs::get $OS .system.class_path]; ::set IndirectFieldList [indirect_field_list_get .class_path $ClassPath]; ::foreach IndirectField $IndirectFieldList { ::set Address /$ObjectId$IndirectField; ::set After [$_database cpp_indirect_find .address $Address]; ::if {$After ne ""} { ::sargs::var::set OS .data$IndirectField $After; } } ::return $OS; } method object_structure_with_indirects_find {sargs} { #2.26.0 /* { Returns object structure with all the indirects loaded as well. */ } ::set OS [object_structure_find $sargs]; ::if {[::sargs::size $OS]==0} { ::return $OS; } ::set ObjectId [::sargs::get $OS .system.object_id]; ::set ClassPath [::sargs::get $OS .system.class_path]; ::set IndirectFieldList [indirect_field_list_get .class_path $ClassPath]; ::foreach IndirectField $IndirectFieldList { /* { We load all the indirect fields into the structures we are keeping. */ } ::set Address /$ObjectId$IndirectField; ::set After [$_database cpp_indirect_find .address $Address]; ::if {$After ne ""} { ::sargs::var::set OS .data$IndirectField $After; } } ::return $OS; } method object_structure_with_indirects_load {sargs} { #2.26.0 ::set OS [object_structure_with_indirects_find $sargs]; ::if {[::sargs::size $OS]==0} { ::qw::bug 314120130523092033 "[::qw::methodname] - can't load \"$sargs\"."; } ::return $OS; } method object_structure_with_indirects_store {sargs} { #2.27.0 /* { The OS has all indirects. We separate and store them separately and trim the object structure before storing it. */ } ::set OS [::sargs::get $sargs .structure]; ::set ObjectId [::sargs::get $OS .system.object_id]; ::set ClassPath [::sargs::get $OS .system.class_path]; ::set IndirectFieldList [indirect_field_list_get .class_path $ClassPath]; ::foreach IndirectField $IndirectFieldList { /* { We store each indirect and remove it from the object structure before storing the object structure itself. */ } ::set After [::sargs::get $OS .data$IndirectField]; ::sargs::var::unset OS .data$IndirectField; ::set Address /$ObjectId$IndirectField; $_database cpp_indirect_store .address $Address .after $After; } $_database cpp_object_structure_store .structure $OS; } method path_readable {sargs} { /* { Get the path to the object using the name at each level, eliminating the tediousness of ids. */ } ::set ObjectId [::sargs::get $sargs .object_id]; if {$ObjectId ne ""} { ::set ObjectStructure [object_structure_load $sargs]; ::set PathName [::sargs::get $_object_structures_by_object_id($ObjectId) .application.path_readable]; ::if {$PathName ne ""} { ::return $PathName; } ::set Path [::sargs::get $ObjectStructure .system.path]; ::if {[::sargs::boolean_get $ObjectStructure .system.is_class]} { ::sargs::var::set _object_structures_by_object_id($ObjectId) .application.path_readable $Path; ::return $Path; } ::set Name [::sargs::get $ObjectStructure .data.name]; ::if {$Name eq ""} { ::set Name [::sargs::get $ObjectStructure .system.object_id]; } ::set BaseObjectId [::sargs::get $ObjectStructure .system.base_object_id]; ::set PathName [path_readable .object_id $BaseObjectId]; ::append PathName /$Name; ::sargs::var::set _object_structures_by_object_id($ObjectId) .application.path_readable $PathName; ::return $PathName; ::set List [::split $BasePathName /]; ::lappend List $Name; ::set PathName [::join $List /]; ::sargs::var::set _object_structures_by_object_id($ObjectId) .application.path_readable $PathName; ::return $PathName; } ::set Address [::sargs::get $sargs .address]; if {$Address ne ""} { ::set ObjectStructure [object_structure_load .address $Address]; ::set ObjectId [::sargs::get $ObjectStructure .system.object_id]; ::return [path_readable .object_id $ObjectId]; } ::qw::bug 314120090128145610 "Could not get object path."; } method path_help {sargs} { /* { Strips off some leading names from the path. */ } ::set Path [path_readable $sargs]; ::switch -glob -- $Path { /OBJECT/NEWVIEWS/ACCOUNT { ::return /ACCOUNT; } /OBJECT/NEWVIEWS/ACCOUNT/* { #*/ ::return [::string map [::list /OBJECT/NEWVIEWS/ACCOUNT ""] $Path]; } } ::set PathHelp [::string map {/OBJECT/NEWVIEWS {}} $Name]; ::return $PathHelp; } method meta_get {sargs} { /* { Returns an object's fully merged meta. Priority of arguments: .class_path .object_id .address .path */ } ::set ClassPath [::sargs::get $sargs .class_path]; ::if {$ClassPath ne ""} { ::if {![::info exists _metas_by_class_path($ClassPath)]} { ::set OS [object_structure_load .path $ClassPath]; ::set BaseMeta ""; # 2.23.0 ::set BaseObjectId [::sargs::get $OS .base_object_id]; ::set BaseObjectId [::sargs::get $OS .system.base_object_id]; ::if {$BaseObjectId ne ""} { ::set BaseMeta [meta_get .object_id $BaseObjectId]; } ::set DerivedMeta [::sargs::get $OS .meta]; ::set Meta [::sargs::+= $BaseMeta $DerivedMeta]; ::set _metas_by_class_path($ClassPath) $Meta; } ::return $_metas_by_class_path($ClassPath); } ::set OS [object_structure_load $sargs]; ::return [meta_get .class_path [::sargs::get $OS .system.class_path]]; } method metas_load {sargs} { /* { This routines makes sure the _metas_by_path is completely loaded. We usually just load metas on demand, but if prior to performing a big operation we know all metas will be loaded anyway, why not just load them all at once? Here we recurse down from the root object, using .system.class_kids to traverse derived classes. */ } ::set ObjectId [::sargs::get $sargs .object_id]; ::if {$ObjectId eq ""} { ::set OS [object_structure_load .path /OBJECT]; ::set ObjectId [::sargs::get $OS .system.object_id]; metas_load .object_id $ObjectId; ::return; } ::set OS [object_structure_load .object_id $ObjectId]; ::set ClassPath [::sargs::get $OS .system.class_path]; ::if {![::info exists _metas_by_class_path($ClassPath)]} { ::set Meta [::sargs::get $sargs .parent_meta]; ::sargs::var::+= Meta [::sargs::get $OS .meta]; ::set _metas_by_class_path($ClassPath) $Meta; } ::set ClassKids [::sargs::get $OS .system.class_kids]; ::foreach ObjectId $ClassKids { metas_load .object_id $ObjectId .parent_meta $_metas_by_class_path($ClassPath); } } method reference_field_list_get {sargs} { ::set ClassPath [::sargs::get $sargs .class_path]; ::if {$ClassPath ne ""} { ::if {![::info exists _reference_field_lists_by_class_path($ClassPath)]} { ::set OS [object_structure_load .path $ClassPath]; ::set Meta [meta_get .class_path $ClassPath]; ::set ReferencePathList [::sargs::select_field_value \ .structure $Meta \ .field .odb.type \ .value reference \ ]; ::set _reference_field_lists_by_class_path($ClassPath) $ReferencePathList; } ::return $_reference_field_lists_by_class_path($ClassPath); } ::set OS [object_structure_load $sargs]; ::return [[::qw::methodname] .class_path [::sargs::get $OS .system.class_path]]; } method pointer_field_list_get {sargs} { ::set ClassPath [::sargs::get $sargs .class_path]; ::if {$ClassPath ne ""} { ::if {![::info exists _pointer_field_lists_by_class_path($ClassPath)]} { ::set OS [object_structure_load .path $ClassPath]; ::set Meta [meta_get .class_path $ClassPath]; ::set PointerPathList [::sargs::select_field_value \ .structure $Meta \ .field .odb.type \ .value pointer \ ]; ::set _pointer_field_lists_by_class_path($ClassPath) $PointerPathList; } ::return $_pointer_field_lists_by_class_path($ClassPath); } ::set OS [object_structure_load $sargs]; ::return [[::qw::methodname] .class_path [::sargs::get $OS .system.class_path]]; } method collection_index_field_list_get {sargs} { /* { Gets the fields under a particular collection. The field paths returned are relative to the collection. If the caller needs a full path it should be easy to build. Usage: ::set IndexFieldList [$_object_structure_manager collection_index_field_list_get \ .class_path $ClassPath \ .collection_field $CollectionField \ ]; */ } ::set ClassPath [::sargs::get $sargs .class_path]; ::if {$ClassPath eq ""} { ::set OS [object_structure_load $sargs]; ::set ClassPath [::sargs::get $sargs .system.class_path]; } ::set CollectionField [::sargs::get $sargs .collection_field]; ::if {$CollectionField eq ""} { ::qw::throw "[::qw::methodname] - no collection field."; } ::if {![::info exists _collection_index_field_lists_by_class_path_collection_field($ClassPath$CollectionField)]} { ::set OS [object_structure_load .path $ClassPath]; ::set Meta [meta_get .class_path $ClassPath]; ::set CollectionMeta [::sargs::get $Meta $CollectionField]; ::set IndexList [::sargs::select_field_value \ .structure $CollectionMeta \ .field .odb.type \ .value index \ ]; ::set _collection_index_field_lists_by_class_path_collection_field($ClassPath$CollectionField) $IndexList; } ::return $_collection_index_field_lists_by_class_path_collection_field($ClassPath$CollectionField); } method indirect_field_list_get {sargs} { ::set ClassPath [::sargs::get $sargs .class_path]; ::if {$ClassPath ne ""} { ::if {![::info exists _indirect_field_lists_by_class_path($ClassPath)]} { ::set OS [object_structure_load .path $ClassPath]; ::set Meta [meta_get .class_path $ClassPath]; ::set FieldList [::sargs::select_field \ .structure $Meta \ .field .odb.type \ ]; ::set BlobPathList [::list]; ::foreach Field $FieldList { ::set Flags [::sargs::get $Meta $Field.odb.flags]; ::if {$Flags ne "" && "0x$Flags"&0x01!=0} { ::lappend BlobPathList $Field; } } ::set _indirect_field_lists_by_class_path($ClassPath) $BlobPathList; } ::return $_indirect_field_lists_by_class_path($ClassPath); } ::set OS [object_structure_load $sargs]; ::return [indirect_field_list_get .class_path [::sargs::get $OS .system.class_path]]; } method field_get {sargs} { ::qw::try { # 2.26.1 load from .os added ::set OS [::sargs::get $sargs .os]; ::if {[::sargs::size $OS]==0} { ::set OS [object_structure_load $sargs]; } ::set Field [::sargs::get $sargs .field]; ::if {$Field eq ""} { ::qw::bug 314120090129101748 "[::qw::methodname] - no field."; } ::set ClassPath [::sargs::get $OS .system.class_path]; ::switch -glob -- $Field { .name { ::return [::sargs::get $OS .data$Field]; } .description { ::return [::sargs::get $OS .data$Field]; } .posting*.amount - .posting*.quantity { /* { 2.25.4 - this case was added - used by cellcon clearing account reconcile script */ } ::switch -glob -- $ClassPath { /OBJECT/NEWVIEWS/SYSTEM/TRANSACTION* { /* { We use file extension to get .amount or .quantity and chop it off to get the posting field. */ } ::set AmountField [::file extension $Field]; ::set PostingField [::string map [::list $AmountField ""] $Field]; ::set Posting [::sargs::get $OS .data$PostingField]; ::set Meta [meta_get .class_path $ClassPath]; ::set PostingMeta [::sargs::get $Meta $PostingField]; ::set Subs [::sargs::subs .structure $PostingMeta]; ::if {[::lempty $Subs]} { ::set Amount [::sargs::get $OS .data$PostingField$AmountField]; ::if {$Amount ne ""} { ::return $Amount; } ::set ObjectId [::sargs::get $OS .system.object_id]; ::set Totals [$_database cpp_file_totals \ .path /odb/index$ClassPath.odb_deriveds.index/id \ .range.begin [::list string $ObjectId] \ .range.end [::list string $ObjectId] \ ]; ::foreach {Path Total} $Totals { ::if {$Path eq "$PostingField$AmountField"} { ::return $Total; } } ::return 0.0; } ::set Amount 0.0; ::foreach Sub $Subs { ::set SubAmount [field_get $sargs .field $PostingField$Sub$AmountField]; ::qw::number::var::add Amount $SubAmount; } ::return $Amount; } } } .journal - .posting*.account - .reference - .date1 - .date { ::switch -glob -- $ClassPath { /OBJECT/NEWVIEWS/SYSTEM/TRANSACTION* { ::set Result [::sargs::get $OS .data$Field]; ::if {$Result ne ""} { ::return $Result; } ::if {[::sargs::boolean_get $OS .system.is_class]} { ::return $Result; } ::set BaseObjectId [::sargs::get $OS .system.base_object_id]; ::set ClassObjectId [::sargs::get $OS .system.class_object_id]; ::if {$BaseObjectId eq $ClassObjectId} { ::return $Result; } ::return [field_get $sargs .os "" .address /$BaseObjectId]; } } } .options.date.format - .options.currency.format { ::set ClassPath [::sargs::get $OS .system.class_path]; ::if {[::string first "/OBJECT/SYSTEM/USER" $ClassPath]<0} { ::return ""; } ::set Result [::sargs::get $OS .data$Field]; ::if {$Result ne ""} { ::return $Result; } ::set BaseObjectId [::sargs::get $OS .system.base_object_id]; ::return [field_get .address /$BaseObjectId .os "" .field $Field]; } } ::set ClassPath [::sargs::get $OS .system.class_path]; ::set Meta [meta_get .path $ClassPath]; ::set OdbInfo [::sargs::get $Meta $Field]; ::if {$OdbInfo eq ""} { ::qw::bug 314120090129104639 "Could not find field \"$Field\"."; } ::set FieldType [::sargs::get $OdbInfo .odb.type]; ::switch -- $FieldType { integer { ::return [::sargs::integer_get $OS $Field]; } real { ::return [::sargs::real_get $OS $Field]; } string - date - reference - pointer { ::return [::sargs::get $OS $Field]; } default { ::qw::bug 314120090129104639 "Encountered invalid field type \"$FieldType\"."; } } /* { ::switch -glob -- $ClassPath { /OBJECT/NEWVIEWS/SYSTEM/TRANSACTION* { :: } default { ::qw::bug 314120090129101749 "Encountered invalid class \"$ClassPath\"."; } } */ } } catch Exception { ::qw::throw [::qw::exception::parent $Exception "Could not get field from arguments \"$args\"."]; } } method name_list {sargs} { /* { #2.23.0 - added for database/screen/window template_export/import Given an object, returns it's name list. The name_list is the path to the object using the .name field, not the object_id. */ } ::set OS [object_structure_find $sargs]; ::if {[::sargs::size $OS]==0} { ::qw::bug 314120130410170633 "[::qw::methodname] - can't find object,sargs==$sargs"; } ::set Name [::sargs::get $OS .data.name]; ::if {$Name eq ""} { ::set ClassPath [::sargs::get $OS .system.class_path]; ::switch -glob -- $ClassPath { /OBJECT/NEWVIEWS/SYSTEM/EMPLOYEE* { /* { Kludge alert: Employees don't use the .name field but instead use the .employee_id field. */ } ::set Name [::sargs::get $OS .data.employee_id]; } /OBJECT/SYSTEM/ACCESS* { /* { No longer applies. */ } # ::qw::bug 314120120321152155 "[::qw::methodname] - unexpected nameless object \"[::sargs::get $OS .system.path]\"."; #::set Name [::sargs::get $OS .system.object_id]; } /OBJECT/NEWVIEWS/SYSTEM/PRICE* { /* { No longer applies. */ } # ::qw::bug 314120120321152156 "[::qw::methodname] - unexpected nameless object\"[::sargs::get $OS .system.path]\"."; # ::set Name [::sargs::get $OS .system.object_id]; } /OBJECT/NEWVIEWS/ACCOUNT { /* { Accounts can be nameless when they are text lines. */ } # ::qw::bug 314120120321152157 "[::qw::methodname] - unexpected nameless object \"[::sargs::get $OS .system.path]\"."; /* { ::if {[::sargs::get $OS .data.line_type] ne "text_line"} { ::qw::bug 314120120318161630 "[::qw::methodname] invalid text line."; } ::set Name [::sargs::get $OS .system.object_id]; */ } } } } ::if {$Name eq ""} { ::return ""; # ::qw::bug 314120120318161631 "[::qw::methodname] - nameless object \"[::sargs::get $OS .system.path]\"."; } ::set NameList [::list $Name]; ::set BaseObjectId [::sargs::get $OS .system.base_object_id]; ::if {$BaseObjectId ne ""} { ::set BaseOS [object_structure_find .object_id $BaseObjectId]; ::set NameList [::concat [[::qw::methodname] .object_id $BaseObjectId] $NameList]; } ::return $NameList; } method name_list_to_key {sargs} { /* { Forms a key string from a namepath. Appends the name_list elements together without spaces and appends the field if any. */ } ::set NameList [::sargs::get $sargs .name_list]; ::if {[::llength $NameList]==0} { ::qw::bug 314120120308130837 "namepath_to_key - empty name_list."; } ::set NameList [::string tolower $NameList]; ::set Key ""; ::foreach Element $NameList { ::append Key $Element; } # ::append Key [::sargs::get $Namepath .field_path]; ::return $Key; } method down_closure_list {sargs} { # 2.26.0 /* { .index_field_list - Uses these indexes at each level. Returns a list of object ids forming the downward closure of the supplied object_id, including the supplied object_id. Because of the nature of down-closures, we cannot guarantee anything about the order. We use a member variables for the result so we can short-circuit when any item has already been visited. Returns a list of object ids all objects under .index_field for a specified root object. Does this recursively. The object is specified by the same arguments as object_structure_load. We return all nodes or just the leafs, depending on the .node.type argument. The nodes are returned in top-down order using the odb_deriveds id index. Can't use name index as that would miss some objects such as text lines. This is very convenient when you simply want to process all of the reports, journals, employees, etc. But it wouldn't be wise to try it on transactions. */ } ::set ObjectId [::sargs::get $sargs .object_id]; ::if {$ObjectId eq ""} { ::qw::bug 314120130412165312 "[::qw::procname] - no object id."; } ::set IndexFieldList [::sargs::get $sargs .index_field_list]; ::if {[::llength $IndexFieldList]==0} { ::qw::bug 314120130412165312 "[::qw::procname] - no index field list."; } ::if {![::sargs::exists $sargs .level]} { /* { We don't really care what the level is. We just want a way to distiguish the original call from recursive calls so we can initialize and cleanup. Note that this is only necessary because we a reusing local member variables and we do that only to make shortcutting easier (when an object is already processed when traversing down-closure is partial order). */ } ::set _down_closure_list [::list]; ::array set _down_closure_array {}; ::array unset _down_closure_array *; [::qw::methodname] $sargs .level 0; ::set ResultList $_down_closure_list; ::set _down_closure_list [::list]; ::array unset _down_closure_array *; ::return $ResultList; } ::set Level [::sargs::get $sargs .level]; ::sargs::var::set sargs .level [::incr Level]; ::if {[::info exists _down_closure_array($ObjectId)]} { /* { The way the algorithm works we don't call if the object has already been processed. */ } ::qw::bug 314120130412165313 "[::qw::procname] - object already processed."; } ::lappend _down_closure_list $ObjectId; ::set _down_closure_array($ObjectId) 1; ::set OS [object_structure_load $sargs]; ::set ClassPath [::sargs::get $OS .system.class_path]; ::foreach IndexField $IndexFieldList { ::set KidAddressList [$_database cpp_file_odb_masters \ .path /odb/index$ClassPath$IndexField \ .range.begin [::list string $ObjectId] \ .range.end [::list string $ObjectId] \ .order_is_kept 0 \ ]; ::foreach KidAddress $KidAddressList { ::set KidObjectId [::qw::odb::object_id_extract .address $KidAddress]; ::if {![::info exists _down_closure_array($KidObjectId)]} { [::qw::methodname] $sargs .object_id $KidObjectId; } } } } method subtree_list {sargs} { # 2.26.0 - generalized deriveds_subtree_list by adding .index_field argument. /* { Usage: $_osm subtree_list .path /OBJECT/ACCOUNT/TOTAL .index_field .odb_deriveds.index/id can use .path, .address or .object_id Returns a list of object ids all objects under .index_field for a specified root object. Does this recursively. The object is specified by the same arguments as object_structure_load. We return all nodes or just the leafs, depending on the .node.type argument. The nodes are returned in top-down order using the odb_deriveds id index. Can't use name index as that would miss some objects such as text lines. This is very convenient when you simply want to process all of the reports, journals, employees, etc. But it wouldn't be wise to try it on transactions. */ } ::set IndexField [::sargs::get $sargs .index_field]; ::if {$IndexField eq ""} { ::qw::bug 314120130405103048 "[::qw::methodname] - no index field."; } ::set NodeType [::sargs::get $sargs .node.type]; ::set OS [object_structure_load $sargs]; ::set ObjectId [::sargs::get $OS .system.object_id]; ::set ClassPath [::sargs::get $OS .system.class_path]; /* { We want the kids and we don't want to use object_list or reference_list because they may check for things that we don't want checked. */ } ::set KidList [$_database cpp_file_odb_masters \ .path /odb/index$ClassPath$IndexField \ .range.begin [::list string $ObjectId] \ .range.end [::list string $ObjectId] \ .order_is_kept 1 \ ]; ::set Result ""; ::switch -- $NodeType { leaf { ::if {[::llength $KidList]==0} { ::lappend Result $ObjectId; } } "" - all { ::lappend Result $ObjectId; } default { ::qw::bug 314120101116212156 "[::qw::methodname] - invalid type \$NodeType\"."; } } ::foreach Kid $KidList { ::set KidObjectId [::qw::odb::object_id_extract .address $Kid]; ::set Result [::concat $Result [[::qw::methodname] $sargs .object_id $KidObjectId]]; } ::return $Result; } method path_folder {sargs} { /* { We get path_readable name and then strip off the last name in the path. */ } ::set Address [::sargs::get $sargs .address]; if {$Address ne ""} { ::set ObjectStructure [object_structure_load $sargs]; ::sargs::var::set sargs .object_id [::sargs::get $ObjectStructure .system.object_id]; } ::set ObjectId [::sargs::get $sargs .object_id]; if {$ObjectId eq ""} { ::qw::bug 314120090128150013 "Encountered empty object id."; } ::set ObjectStructure [object_structure_load $sargs]; ::set BaseObjectId [::sargs::get $ObjectStructure .system.base_object_id]; ::set Folder [path_readable .object_id $BaseObjectId]; ::switch -glob -- $Folder { /OBJECT/NEWVIEWS/ACCOUNT - /OBJECT/NEWVIEWS/ACCOUNT/* { #*/ ::set Folder [::string map {/OBJECT/NEWVIEWS/ACCOUNT {}} $Folder]; ::if {$Folder eq ""} { ::return "/ACCOUNT"; } } /OBJECT/NEWVIEWS/JOURNAL - /OBJECT/NEWVIEWS/JOURNAL/* { #*/ ::set Folder [::string map {/OBJECT/NEWVIEWS/JOURNAL {}} $Folder]; ::if {$Folder eq ""} { ::return "/JOURNAL"; } } /OBJECT/NEWVIEWS/REPORT - /OBJECT/NEWVIEWS/REPORT/* { #*/ ::set Folder [::string map {/OBJECT/NEWVIEWS/REPORT {}} $Folder]; ::if {$Folder eq ""} { ::return "/REPORT"; } } /OBJECT/NEWVIEWS/SYSTEM/TRANSACTION - /OBJECT/NEWVIEWS/SYSTEM/TRANSACTION/* { #*/ ::set Folder [::string map {/OBJECT/NEWVIEWS/SYSTEM/TRANSACTION {}} $Folder]; ::if {$Folder eq ""} { ::return "/TRANSACTION"; } } } ::return $Folder; } method dump_all_index_records {} { ::set TextFile [::file join [::file dirname $_database_path] all_index_records.txt]; ::set InodesFile [$_database cpp_file_factory]; ::qw::finally [::list $InodesFile cpp_destroy]; $InodesFile cpp_file_open .path /; ::set RecordCount 0; ::for {::set Record [$InodesFile cpp_record_first];} {$Record ne ""} {::set Record [$InodesFile cpp_record_next $Record];} { ::set Data [::sargs::get $Record .data]; ::set Path [::sargs::get $Data .path]; ::if {[::string first "/odb/index" $Path]==0} { ::incr RecordCount [$_database cpp_file_record_count .path $Path]; } } ::set ProgressLimit $RecordCount; ::set Progress ""; ::set ProgressMinimum 1; ::if {$ProgressLimit>=$ProgressMinimum} { ::set Progress [::itcl::local ::QW::PROGRESS::OPERATION #auto \ .database_id $_database_id \ .file $_database_path \ .limit $ProgressLimit \ .resolution 109 \ .operation "dumping index records" \ .status "$_database_path dumping index records to $TextFile." \ ]; } ::set Handle [::open $TextFile w+]; ::qw::finally [::list ::close $Handle]; ::set IfsFile [$_database cpp_file_factory]; ::qw::finally [::list $IfsFile cpp_destroy]; ::for {::set InodeRecord [$InodesFile cpp_record_first];} {[::sargs::size $InodeRecord]!=0} {::set InodeRecord [$InodesFile cpp_record_next $InodeRecord];} { ::set Data [::sargs::get $InodeRecord .data]; ::set Path [::sargs::get $Data .path]; ::if {[::string first "/odb/index" $Path]==0} { ::puts $Handle "---------------- $Path"; $IfsFile cpp_file_open .path $Path; ::for {::set IndexRecord [$IfsFile cpp_record_first];} {$IndexRecord ne ""} {::set IndexRecord [$IfsFile cpp_record_next $IndexRecord];} { ::puts $Handle $IndexRecord; $Progress increment; } } } } method dump_all_interactive_index_records {} { ::set TextFile [::file join [::file dirname $_database_path] all_interactive_index_records.txt]; ::set InodesFile [$_database cpp_file_factory]; ::qw::finally [::list $InodesFile cpp_destroy]; $InodesFile cpp_file_open .path /; ::set RecordCount 0; ::for {::set InodeRecord [$InodesFile cpp_record_first];} {[::sargs::size $InodeRecord]!=0} {::set InodeRecord [$InodesFile cpp_record_next $InodeRecord];} { ::set Data [::sargs::get $InodeRecord .data]; ::set Path [::sargs::get $Data .path]; ::switch -glob -- $Path { "/odb/index*/interactive*" - "/odb/index*/z" - "/odb/index*/tab" - "/odb/index*/tile" { ::incr RecordCount [$_database cpp_file_record_count .path $Path]; } } } ::set ProgressLimit $RecordCount; ::set Progress ""; ::set ProgressMinimum 1; ::if {$ProgressLimit>=$ProgressMinimum} { ::set Progress [::itcl::local ::QW::PROGRESS::OPERATION #auto \ .database_id $_database_id \ .file $_database_path \ .limit $ProgressLimit \ .resolution 109 \ .operation "dumping index records" \ .status "$_database_path dumping index records to $TextFile." \ ]; } ::set Handle [::open $TextFile w+]; ::qw::finally [::list ::close $Handle]; ::set IfsFile [$_database cpp_file_factory]; ::qw::finally [::list $IfsFile cpp_destroy]; ::for {::set InodeRecord [$InodesFile cpp_record_first];} {[::sargs::size $InodeRecord]!=0} {::set InodeRecord [$InodesFile cpp_record_next $InodeRecord];} { ::set Data [::sargs::get $InodeRecord .data]; ::set Path [::sargs::get $Data .path]; ::switch -glob -- $Path { "/odb/index*/interactive*" - "/odb/index*/z" - "/odb/index*/tab" - "/odb/index*/tile" { ::set RecordCount [$_database cpp_file_record_count .path $Path]; ::if {$RecordCount!=0} { ::puts $Handle "---------------- $Path"; $IfsFile cpp_file_open .path $Path; ::for {::set IndexRecord [$IfsFile cpp_record_first];} {[::sargs::size $IndexRecord]!=0} {::set IndexRecord [$IfsFile cpp_record_next $IndexRecord];} { ::puts $Handle $IndexRecord; ::set Reference [::lindex [::sargs::get $IndexRecord .key] end]; ::if {[::string match "*.clipper.parent" $Reference]} { ::if {![::string match "*.clipper.kids.index/z" $Path]&&![::string match "*.clipper.kids.index/tile" $Path]} { ::qw::bug 314120120408134645 "Invalid interactive record."; } } ::if {[::string match "*.clipper.kids.index/z" $Path]||[::string match "*.clipper.kids.index/tile" $Path]} { ::if {![::string match "*.clipper.parent" $Reference]} { ::qw::bug 314120120408134646 "Invalid interactive record."; } } ::if {[::string match "*.odb_base" $Reference]} { ::if {![::string match "*.odb_deriveds.index/*" $Path]} { ::qw::bug 314120120408134647 "Invalid interactive record."; } } ::if {[::string match "*.odb_deriveds.index/*" $Path]} { ::if {![::string match "*.odb_base" $Reference]} { ::qw::bug 314120120408134648 "Invalid interactive record."; } } $Progress increment; } } } } } } method access_object_list {sargs} { /* { Returns the list of objects to which the current user has access. They are returned as object_ids in no particular order. .return_type - return a list of object_id or name_lists object_id name_list */ } ::if {$_database_type ne "application"} { ::return [::list]; } ::set User $_user; ::if {$User eq ""} { ::set User [::sargs::get $sargs .user]; } ::if {$User eq ""} { /* { We need a user to be specified because this method can be called before a user has been logged in; specifically to find a screen template. */ } ::qw::bug 314120120415115757 "[::qw::methodname] - no user."; } ::set ReturnType [::sargs::get $sargs .return_type]; ::switch -- $ReturnType { object_id { } "" - name_list { } default { ::qw::bug 314120120528161014 "[::qw::methodname] - invalid return type \"$ReturnType\"."; } } ::set UserOS [object_structure_load .address $User]; ::set ObjectId [::sargs::get $UserOS .system.object_id]; ::set ClassPath [::sargs::get $UserOS .system.class_path]; ::set AccessToList [$_database cpp_file_odb_masters \ .path /odb/index$ClassPath.access_tos.index/id \ .range.begin [::list string $ObjectId] \ .range.end [::list string $ObjectId] \ ]; ::if {[::llength $AccessToList]==0} { ::return [::list]; } ::set AccessObjectList [::list]; ::foreach AccessTo $AccessToList { ::set AccessToOS [$_database cpp_object_structure_load .address $AccessTo]; ::set AccessObject [::sargs::get $AccessToOS .data.object]; ::if {$AccessObject eq ""} { /* { 2.27.0 Access objects can have empty object references so it was a mistake to throw an exception. A user tripped over this. */ } ::continue; #::qw::bug 314120120413192055 "[::qw::methodname] - \"$AccessTo\" has no access object."; } ::set AccessObjectOS [object_structure_load .address $AccessObject]; ::set AccessObjectId [::sargs::get $AccessObjectOS .system.object_id]; ::switch -- $ReturnType { "" - object_id { ::lappend AccessObjectList $AccessObjectId; } name_list { ::lappend AccessObjectList [name_list .object_id $AccessObjectId]; } } } ::return $AccessObjectList; } method root_class_path {sargs} { /* { Returns the class_path of the class that introduced a field. We are given the field address. This method was created to support the storage of mru_lists when the key for the field's data was created from its root class path. That was changed to the window_class_path/column_name, so this method is not longer used. I just hated to throw it away. */ } ::set FieldAddress [::sargs::get $sargs .field_address]; ::if {$FieldAddress eq ""} { ::qw::bug 314120120513100404 "[::qw::methodname] - no field address."; } ::set ObjectAddress [::qw::odb::object_address_extract .address $FieldAddress] ::set Field [::qw::odb::field_extract .address $FieldAddress] ::set OS [object_structure_load .address $FieldAddress]; ::set Meta [meta_get .address $FieldAddress]; ::if {![::sargs::exists $Meta $Field]} { ::qw::bug 314120120513100405 "[::qw::methodname] - undefined field \"$Field\"."; } ::set ClassPath [::sargs::get $OS .system.class_path]; while {1} { /* { Next line removes the last element of of the path, thereby giving us the base class path. */ } ::set BaseClassPath [::join [::lrange [::split $ClassPath /] 0 end-1] /]; ::if {$BaseClassPath eq ""} { /* { This field must have been introduced by the root object class. */ } ::return $ClassPath; } ::set BaseMeta [meta_get .class_path $BaseClassPath]; ::if {![::sargs::exists $BaseMeta $Field]} { /* { We reached the class above the class that introduced the field. Return the class path that introduced the field. */ } ::return $ClassPath; } ::set ClassPath $BaseClassPath; } ::qw::bug 314120120513102046 "[::qw::methodname] - can't find root class for field \"$Field\"."; } method account_index_closure {sargs} { /* { Returns the list of object ids of each object in the closure of an index. We are given an object id and an index field. We need to return the closure list so the caller can insert into the each object's index. */ } ::set ObjectId [::sargs::get $sargs .object_id]; ::if {$ObjectId eq ""} { ::qw::bug 314120120625083444 "[::qw::methodname] - no object id."; } ::set IndexField [::sargs::get $sargs .index_field]; ::if {$IndexField eq ""} { ::qw::bug 314120120625083445 "[::qw::methodname] - no index field."; } ::set OS [object_structure_load $sargs]; ::set ClassPath [::sargs::get $OS .system.class_path]; ::set Meta [meta_get .class_path $ClassPath]; ::set ResultList [::list]; ::if {[::sargs::exists $Meta $IndexField]} { ::lappend ResultList $ObjectId; ::set BaseObjectId [::sargs::get $OS .system.base_object_id]; ::if {$BaseObjectId ne ""} { ::set ResultList [::concat $ResultList [[::qw::methodname] $sargs .object_id $BaseObjectId]]; } } ::return $ResultList; } method tag_list_get {sargs} { /* { Scans the journal hierarchy to build a list of all tags in use. */ } ::if {$_tag_list ne ""} { ::return $_tag_list; } ::set Journal [::sargs::get $sargs .address]; ::if {$Journal eq ""} { ::set OS [$_database cpp_object_structure_load .path /OBJECT/NEWVIEWS/JOURNAL]; ::set _tag_list [tag_list_get .address /[::sargs::get $OS .system.object_id]]; ::return $_tag_list; } ::set OS [$_database cpp_object_structure_load .address $Journal]; ::set ObjectId [::sargs::get $OS .system.object_id]; ::set ClassPath [::sargs::get $OS .system.class_path]; ::set Kids [$_database cpp_file_odb_masters \ .path /odb/index$ClassPath.odb_deriveds.index/id \ .range.begin [::list string $ObjectId] \ .range.end [::list string $ObjectId] \ ]; ::set TagList [::sargs::get $OS .data.tags]; ::foreach Kid $Kids { ::set TagList [::qw::union $TagList [tag_list_get .address $Kid]]; } ::return $TagList; } /* { # moved into specific export/import script pairs method wrap_reference_fields {sargs} { #2.26.0 - moved in from database_template_export /* { Processing Reference and Pointer Fields --------------------------------------- THe address in database1 will not work in database2. However, if every object we point to is a named object, then we should be able to find it from a name_list. There are some nameless objects that are pointed to. The prime example is the transaction/distribution. There are some nameless objects such as adut records, sessions, accesses etc. where the only nameless object that is pointed to is a class object, which actually has a name. Since we are not exporting any of these we can get away with using a name_list to find objects in database2. What is a name_list? -------------------- It is the path to a named object using names in a list. We can follow the .odb_deriveds.index/name to find it. We have to use a list instead of a path-like /a/b/c syntax because unlike ids, names can have special characters and whitespace. */ } ::set OS [::sargs::get $sargs .os]; ::set Tag [::sargs::get $sargs .tag]; ::if {$Tag eq ""} { ::set Tag "odb_address" } ::if {[::sargs::size $OS]==0} { ::qw::bug 314120130405141034 "[::qw::methodname] - no object structure."; } ::set ClassPath [::sargs::get $OS .system.class_path]; ::set ReferenceFieldList [reference_field_list_get .class_path $ClassPath]; ::foreach ReferenceField $ReferenceFieldList { /* { Process the references. Replace each address with a structure containing the object_id, name_list and field_path. */ } ::set Target [::sargs::get $OS .data$ReferenceField]; ::if {$Target eq ""} { ::continue; } ::set TargetObjectId [::qw::odb::object_id_extract .address $Target]; ::set NameList [::join [name_list .object_id $TargetObjectId] <%>]; ::set TargetField [::qw::odb::field_extract .address $Target]; ::set Replacement [::qw::odb::name_value_wrap .tag $Tag .list [::list \ .type reference \ .object_id $TargetObjectId \ .field $TargetField \ .name_list $NameList \ ]]; ::sargs::var::set OS .data$ReferenceField $Replacement; } ::return $OS; } method wrap_pointer_fields {sargs} { #2.26.0 - moved in from database_template_export /* { */ } ::set AppOsm [::sargs::get $sargs .apposm]; ::set OS [::sargs::get $sargs .os]; ::set Tag [::sargs::get $sargs .tag]; ::if {$Tag eq ""} { ::set Tag "odb_address" } ::if {[::sargs::size $OS]==0} { ::qw::bug 314120130405141035 "[::qw::methodname] - no object structure."; } ::set ClassPath [::sargs::get $OS .system.class_path]; ::set PointerFieldList [pointer_field_list_get .class_path $ClassPath]; ::foreach PointerField $PointerFieldList { ::set Target [::sargs::get $OS .data$PointerField]; ::if {$Target eq ""} { ::continue; } ::set TargetObjectId [::qw::odb::object_id_extract .address $Target]; ::set TargetField [::qw::odb::field_extract .address $Target]; ::set DatabaseId [::qw::odb::database_id_extract .address $Target]; ::set NameList ""; ::if {$DatabaseId eq $_database_id} { ::if {[object_structure_exists .object_id $TargetObjectId]} { ::set NameList [::join [name_list .object_id $TargetObjectId] <%>]; } else { ::qw::warning 314120130405170102 "Could not find object $TargetObjectId in database $_database_path"; } ::set Replacement [::qw::odb::name_value_wrap .tag $Tag .list [::list \ .type pointer \ .object_id $TargetObjectId \ .database_id $DatabaseId \ .field $TargetField \ .name_list $NameList \ ]]; ::sargs::var::set OS .data$PointerField $Replacement; ::continue; } ::if {$AppOsm eq ""} { ::continue; } ::if {$DatabaseId eq [[$AppOsm database] cpp_database_id]} { ::if {[$AppOsm object_structure_exists .object_id $TargetObjectId]!=0} { ::set NameList [::join [$AppOsm name_list .object_id $TargetObjectId] <%>]; } else { ::qw::warning 314120130405170103 "Could not find object $TargetObjectId in database [[$AppOsm database] cpp_database_path]."; } ::set Replacement [::qw::odb::name_value_wrap .tag $Tag .list [::list \ .type pointer \ .object_id $TargetObjectId \ .database_id $DatabaseId \ .field $TargetField \ .name_list $NameList \ ]]; ::sargs::var::set OS .data$PointerField $Replacement; ::continue; } } ::return $OS; } method wrap_floating_addresses {sargs} { #2.26.0 - moved in from database_template_export /* { */ } ::set OS [::sargs::get $sargs .os]; ::if {[::sargs::size $OS]==0} { ::qw::bug 314120130405141036 "[::qw::methodname] - no object structure."; } ::set Tag [::sargs::get $sargs .tag]; ::if {$Tag eq ""} { ::set Tag "odb_address" } ::set Result ""; ::set FindPos 0; ::set Pattern "::qw::odb::${_database_id}::"; ::while {1} { ::set Pos [::string first $Pattern $OS $FindPos]; ::if {$Pos<0} { ::append Result [::string range $OS $FindPos end]; ::break; } ::append Result [::string range $OS $FindPos [::expr {$Pos-1}]]; ::set Pos [::expr {$Pos+[::string length $Pattern]}]; ::set EndPos $Pos; ::while {1} { /* { Extracting the "/1295565749_409.clipper.parent" part of the address. */ } ::if {$EndPos==[::string length $OS]} { ::incr EndPos -1; ::break; } ::set Char [::string index $OS $EndPos]; ::if {[::string is alnum $Char]} { ::incr EndPos 1; ::continue; } ::switch -- $Char { "/" - ":" - "." - "_" { ::incr EndPos 1; ::continue; } } ::incr EndPos -1; ::break; } ::set String [::string range $OS $Pos $EndPos]; ::set FindPos [::expr {$Pos+[::string length $String]}]; ::set TargetObjectId [::qw::odb::object_id_extract .address $String]; ::if {![$_database cpp_object_structure_exists .object_id $TargetObjectId]} { ::set NameList ""; ::set BreadCrumbsList [::sargs::get $OS .data.breadcrumbs_list]; ::qw::warning 314120130410185124 "[::qw::methodname] - object cnnot be found for floating address \"$Pattern$String\"."; ::continue } else { ::set NameList [::join [name_list .object_id $TargetObjectId] <%>]; } ::set TargetField [::qw::odb::field_extract .address $String]; ::append Result [::qw::odb::name_value_wrap .tag $Tag .list [::list \ .type floating \ .object_id $TargetObjectId \ .field $TargetField \ .database_id $_database_id \ .name_list $NameList \ ]]; } ::return $Result; } */ } method populate_transaction_date1 {sargs} { /* { We are moving date1 values from a structure field into the .date1 field. We have to update related indexes. The indexes are: JOURNAL.transactions/date1 ACCOUNT.postings/date1 */ } } method totalto_closure {sargs} { /* { We are posting to an account. */ } } }