# ------------------------------------------------------------ # Copyright (c) 2003-2020 # Q.W.Page Associates Inc. # www.qwpage.com # All rights reserved. # ------------------------------------------------------------ ::namespace eval ::qw::script {} ::set ::qw::script::namespace ""; ::set ::qw::script::_next_namespace_id 0; ::set ::qw::script::auto_path [::list \ $::qw_program_path \ [::file join $::qw_program_path system service] \ [::file join $::qw_program_folder nv2.dat scripts] \ $::qw_program_folder \ ]; ::proc ::qw::script::source {sargs} { ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,qw::script::source,1000.0,script_path==[::sargs::get $sargs .script.path]";} ::set ScriptPath [::sargs::get $sargs .script.path]; /* { 2.34.0 Added .script.source argument. Can be used instead of .script.path. Just changes where we get the source. For example, you can use .script.source with encryted code using 314120061121091441. */ } /* { 2.34.0 ::if {$ScriptPath eq ""} { ::qw::throw "Empty script path."; } */ } ::if {$ScriptPath ne ""} { ::if {[::file pathtype $ScriptPath] eq "relative"} { # ------------------------------------------------------------ # Relative paths are relative to $::qw_program_folder (vfs) # 2.31.0 - added nv2.dat/scripts to default paths that we check # ------------------------------------------------------------ /* { When using cpp_database_source_remote_script we were attempting to run a script on a server from a workstation. It didn't work unless the nv.exe files on the workstation and server were in the same folder (i.e. had the same absolute path). So instead, we use a relative path and when relative, we prefix it with the various folders contained in ::qw::script::auto_path. */ } ::if {$rwb1_debug} {::puts "rwb1_debug,qw::script::source,1000.1,::qw::script::auto_path==$::qw::script::auto_path";} ::if {[::file extension $ScriptPath] eq ""} { ::append ScriptPath ".qw_script"; } ::foreach Folder $::qw::script::auto_path { ::set AbsolutePath [::file join $Folder $ScriptPath]; ::if {$rwb1_debug} {::puts "rwb1_debug,qw::script::source,1000.2,Folder==$Folder,AbsolutePath==$AbsolutePath";} ::if {[::file exists $AbsolutePath]} { ::if {![::file isfile $AbsolutePath]} { ::qw::throw "Expected \"$ScriptPath\" to be a file."; } /* { Found relative path when converted to absolute path. */ } ::if {$rwb1_debug} {::puts "rwb1_debug,qw::script::source,1000.3";} ::set ScriptPath $AbsolutePath; ::sargs::var::set sargs .script.path $AbsolutePath; ::break; } } } ::if {$rwb1_debug} {::puts "rwb1_debug,qw::script::source,1000.4";} ::if {![::file exists $ScriptPath]} { ::qw::throw "Could not find script file \"$ScriptPath\"."; } ::if {$rwb1_debug} {::puts "rwb1_debug,qw::script::source,1000.5";} ::if {![::file isfile $ScriptPath]} { ::qw::throw "Expected \"$ScriptPath\" to be a file."; } ::if {$rwb1_debug} {::puts "rwb1_debug,qw::script::source,1000.11,script_path==$ScriptPath";} ::if {![::file exists $ScriptPath]} { ::qw::throw "Could not find script \"$ScriptPath\"."; } ::if {[::file isdirectory $ScriptPath]} { ::qw::throw "Can't run script \"$ScriptPath\" because it is a folder."; } ::if {![::file isfile $ScriptPath]} { ::qw::throw "Can't run script \"$ScriptPath\" because it is not a file."; } /* { The following check caused problems on some computers so it was removed. ::if {[::file executable $ScriptPath]} { ::qw::throw "\"$ScriptPath\" is an executable file."; } */ } ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::boot::script_run_on_demand,1000.12";} ::if {![::file readable $ScriptPath]} { ::qw::throw "Can't run script \"$ScriptPath\" because it is not readable by the current user."; } ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::boot::script_run_on_demand,1000.13";} ::if {$::tcl_platform(platform)=="windows"} { ::array set Attributes [::file attributes $ScriptPath]; ::if {$Attributes(-system)} { ::qw::throw "Can't run script \"$ScriptPath\" because it is a system file."; } } ::set Script [::qw::fileutil::file_read .path $ScriptPath]; } else { # ------------------------------------------------------------ # Specified .script.source instead of .script.path. # ------------------------------------------------------------ /* { This is used by nv2 update because we download the update script from the server and then eval it on the client. */ } ::set Script [::sargs::get $sargs .script.source]; ::if {$Script eq ""} { ::qw::throw "::qw::script::source - no script source code specified."; } } /* { As a convenience to the script writer we set various fields in .script as shown below. We do this with a call to qw::file::info which breaks a path into its various components and returns them in a structure. When script c:/nv2/object/system/audit/somescript.qw_script is run, the structure would be set as follow: .script { .path c:/nv2/object/system/audit/somescript.qw_script .directory c:/nv2/object/system/audit .tail somescript.qw_script .name somescript .extension .qw_script } */ } # 2.25.1 This was putting too much noise in the sargs. # 2.25.1 ::sargs::var::set sargs .script [::sargs::+= [::sargs::get $sargs .script] [::qw::file::info $ScriptPath]]; /* { We save the current namespace value and restore it before we return, even if an exception is thrown. Some scripts use ::qw::script::namespace which seems ok until the script in turn sources another and the variable gets clobbered. What they really should do is save it somewhere. The database_id_set script failed doing this after qw_chtml_compile was sourced. */ } ::if {$rwb1_debug} {::puts "rwb1_debug,qw::script::source,1000.12";} ::set SaveNamespace $::qw::script::namespace; /* { We create a unique namespace and source the script. If the script throws an exception we destroy the namespace and re-throw. Otherwise we save the result so we can return it later. */ } ::if {$rwb1_debug} {::puts "rwb1_debug,qw::script::source,1000.13";} ::set NamespaceId [::incr ::qw::script::_next_namespace_id]; ::sargs::var::set sargs .script.namespace_id $NamespaceId; ::set Namespace "::qw::script::$NamespaceId"; ::set ::qw::script::namespace $Namespace; ::sargs::var::set sargs .script.namespace $Namespace; ::if {$rwb1_debug} {::puts "rwb1_debug,qw::script::source,1000.14";} ::namespace eval $Namespace {}; ::qw::try { ::if {$rwb1_debug} {::puts "rwb1_debug,qw::script::source,1000.15";} #2.34.0 ::set Script [::qw::fileutil::file_read .path $ScriptPath]; ::if {$rwb1_debug} {::puts "rwb1_debug,qw::script::source,1000.16";} ::if {[::sargs::exists $Script .314120061121091441]} { # ------------------------------------------------------------ # Script was encrypted using DES. # ------------------------------------------------------------ /* { If the script has the form of a structure and contains a field with the unique number shown, then it has been encrypted and we must decrypt it before evaluating it. */ } ::if {![[::qw::system] cpp_checksum_check $Script]} { ::qw::throw \ .text "Detected uncontrolled changes in file \"$ScriptPath\"." \ .help_id 314120061121100420 \ .file $ScriptPath \ ; } ::if {$rwb1_debug} {::puts "rwb1_debug,qw::script::source,1000.17";} ::set Script [::sargs::get $Script .314120061121091441]; # ::package require base64; ::package require tclDES ::set Script [::base64::decode $Script]; ::set KeySet [::des::keyset create "16180339"] ::if {$rwb1_debug} {::puts "rwb1_debug,qw::script::source,1000.18";} ::set Script [::des::decrypt $KeySet $Script] ::if {$rwb1_debug} {::puts "rwb1_debug,qw::script::source,1000.19";} ::des::keyset destroy $KeySet; ::if {$rwb1_debug} {::puts "rwb1_debug,qw::script::source,1000.20";} } ::if {[::sargs::exists $Script .314120151209121423]} { # ------------------------------------------------------------ # Script was encrypted using AES. # ------------------------------------------------------------ /* { If the script has the form of a structure and contains a field with the unique number shown, then it has been encrypted and we must decrypt it before evaluating it. */ } ::if {![[::qw::system] cpp_checksum_check $Script]} { ::qw::throw \ .text "Detected uncontrolled changes in file \"$ScriptPath\"." \ .help_id 314120061121100420 \ .file $ScriptPath \ ; } ::if {$rwb1_debug} {::puts "rwb1_debug,qw::script::source,1000.21";} ::set Script [::sargs::get $Script .314120151209121423]; # ::package require base64; ::set Script [::base64::decode $Script]; ::set Key "qw_tcl_key_16180339"; ::if {$rwb1_debug} {::puts "rwb1_debug,qw::script::source,1000.22";} ::set Script [::qw::aes::decrypt .key "qw_tcl_key_16180339" .cipher_text $Script] ::if {$rwb1_debug} {::puts "rwb1_debug,qw::script::source,1000.23";} } /* { 2.23.0 The script should be evaluated in the global namespace. We were evaluting it in ::qw::script. ::set Result [::eval $Script]; */ } # ::if {$rwb1_debug} {::puts "rwb1_debug,qw::script::source,1000.24.0,sargs==\n[::sargs::format $sargs]";} /* { ::if {$rwb1_debug} { ::puts "rwb1_debug,qw::script::source,1000.24.0,script=="; ::puts "-------------------------------------------------------"; ::puts "$Script"; ::puts "-------------------------------------------------------"; } */ } ::set Result [::namespace eval :: $Script]; ::if {$rwb1_debug} {::puts "rwb1_debug,qw::script::source,1000.25.0";} } catch Exception { ::if {$rwb1_debug} {::puts "rwb1_debug,qw::script::source,1000.25.1,script_path==[::sargs::get $sargs .script.path],Exception==$Exception";} ::qw::try { ::namespace delete $Namespace; } catch Dummy {} ::qw::throw $Exception; } /* { If the script did not use the namespace we destroy it now and return the result. The script is not using the protocol so we behave exactly like the tcl ::source statement. */ } ::if {$rwb1_debug} {::puts "rwb1_debug,qw::script::source,1000.26";} ::if { [::llength [::info commands ${Namespace}::*]]==0 &&[::llength [::info vars ${Namespace}::*]]==0 &&[::llength [::namespace children $Namespace]]==0 } { ::qw::try { ::if {$rwb1_debug} {::puts "rwb1_debug,qw::script::source,1000.27";} ::namespace delete $Namespace; ::if {$rwb1_debug} {::puts "rwb1_debug,qw::script::source,1000.28";} } catch Dummy {} ::set ::qw::script::namespace $SaveNamespace; ::return $Result; } /* { We append the current sargs to the script stack. Before doing so, we remove the stack itself from within the original args. Otherwise, each element in the stack would contain a stack. */ } ::if {$rwb1_debug} {::puts "rwb1_debug,qw::script::source,1000.29";} ::if {$::qw::control(script_stack_is_enabled)} { ::set CallerStack [::sargs::get $sargs .script.stack]; ::if {[::sargs::exists $sargs .script.stack]} { ::sargs::var::unset sargs .script.stack; } ::set CalleeStack $CallerStack; ::lappend CalleeStack $sargs; ::sargs::var::set sargs .script.stack $CalleeStack; } ::if {$rwb1_debug} {::puts "rwb1_debug,qw::script::source,1000.30";} ::qw::finally [::subst -nocommands { ::if {[::qw::command_exists ${Namespace}::cleanup]} { /* { If cleanup exists we call it. We ignore any exceptions it might throw. For completeness we pass cleanup the same arguments that were passed to main. The cleanup proc will generally destroy the namespace for short-lived scripts. For long-lived scripts, destroying the namespaces is none of our business. Note that we call cleanup, if it exists, whether or not there was a main. */ } ::qw::try { ${Namespace}::cleanup; # ${Namespace}::cleanup $sargs; } catch Dummy { } } }]; ::if {$rwb1_debug} {::puts "rwb1_debug,qw::script::source,1000.31";} ::qw::finally [::list ::set ::qw::script::namespace $SaveNamespace]; ::if {$rwb1_debug} {::puts "rwb1_debug,qw::script::source,1000.32";} ::if {[::qw::command_exists ${Namespace}::main]} { /* { If main exists we call it. If it returns, we return the result. If it throws an exception we destroy the namespace and re-throw. */ } ::if {$rwb1_debug} {::puts "rwb1_debug,qw::script::source,1000.32.0,Namespace==$Namespace";} ::if {$rwb1_debug} {::puts "rwb1_debug,qw::script::source,1000.32.0.0,sargs==$sargs";} ::set Result [${Namespace}::main $sargs]; ::if {$rwb1_debug} {::puts "rwb1_debug,qw::script::source,1000.32.1,result==$Result";} ::return $Result; } ::if {$rwb1_debug} {::puts "rwb1_debug,qw::script::source,1000.33";} ::return $Result; } ::proc ::qw::script::encrypt {sargs} { /* { The encrypted file is a structure with two fields, .314120061121091441 and .checksum. The unique id is enough to identify the encryption technique. If we add other techniques we will use additional unique ids. The ::qw::script::source command simply loads the script and checks for a non-empty structure field with the unique id. If it exists, then the value of the field is the base64 of the encrypted script. 2.28.3 Added 314120151209121423 for fast cpp-based aes excryption. returns an encrypted structure .plaintext If specified then this is the plain text to be encrypted. .file_in If specified then this file contains the plain text to be encrypted. .file_out If specified then encrypted structure is written to this file. .encryption_type des/aes Note .file_in and .file_out can be the same file and it will still work. */ } # ::package require base64; ::set PlainText ""; ::set FileIn ""; ::qw::try { ::if {[::sargs::exists $sargs .plaintext]} { ::set PlainText [::sargs::get $sargs .plain_text]; } ::set FileInDate ""; ::set FileIn [::sargs::get $sargs .file_in]; ::if {$FileIn ne ""} { ::set PlainText [::qw::fileutil::file_read .path $FileIn]; ::set FileInDate [::file mtime $FileIn]; } ::if {[::sargs::exists $PlainText .314120151209121423]} { ::qw::throw \ .text "Attempted to encrypt data that is already encrypted." \ .error_id 324120151209183211 \ ; } ::if {[::sargs::exists $PlainText .314120061121091441]} { ::qw::throw "Attempted to encrypt data that is already encrypted." } ::switch -- [::string tolower [::sargs::get $sargs .encryption_type]] { "des" - 314120061121091441 { # ------------------------------------------------------------ # DES # ------------------------------------------------------------ ::package require tclDES ::while {[::string length $PlainText]%8} { /* { The encryption requires text with a multiple of 8 bytes. Rather than allow the encryption to add who-knows-what to pad the text, we explicitly add linefeeds which are harmless when sourcing tcl scripts. */ } ::append PlainText "\n"; } ::set KeySet [::des::keyset create "16180339"]; ::set CipherText [::des::encrypt $KeySet $PlainText] ::des::keyset destroy $KeySet; ::set CipherText [::base64::encode $CipherText] ::sargs::var::set Structure .314120061121091441 $CipherText; } "aes" - "" - 314120151209121423 { # ------------------------------------------------------------ # AES # ------------------------------------------------------------ /* { 2.34.2 Corrected a bug in 2.34.1 which called qw::aes::encrypt instead of qw::aes::decrypt. */ } ::set CipherText [::qw::aes::encrypt .key "qw_tcl_key_16180339" .plain_text $PlainText .pad_char "\n"]; ::set CipherText [::base64::encode $CipherText] ::sargs::var::set Structure .314120151209121423 $CipherText; } default { ::qw::bug 314120151209152835 "Invalid encryption type \"$Type\"."; } } ::sargs::var::set Structure .mtime $FileInDate; ::set Structure [[::qw::system] cpp_checksum_set $Structure]; ::set FileOut [::sargs::get $sargs .file_out]; ::set Structure [::sargs::format .structure $Structure]; ::if {$FileOut ne ""} { ::qw::try { ::qw::fileutil::file_write .path $FileOut .data $Structure; # ::set Handle [::open $FileOut w+]; # ::puts -nonewline $Handle $Structure; # ::close $Handle; } catch Exception { ::qw::throw [::qw::exception::nest .sub $Exception .super "Could not write excrypted data to file \"$FileOut\"."]; } } ::return $Structure; } catch Exception { ::if {$FileIn ne ""} { ::qw::throw [::qw::exception::nest .sub $Exception .super "Could not encrypt file \"$FileIn\"."]; } ::qw::throw $Exception; } } ::proc ::qw::script::options_file {sargs} { /* { A script is called with sargs and it can get its own path as follows: ::set ScriptPath [::sargs::get $sargs .script.path]; However, this path is often in the qw_library (i.e. in the vfs) and the options are in qw_data (i.e. nv2 dat, so they are not in the vfs). If the script path is in the qw_library we replace the qw_library part with qw_data. This re-maps the options to a separate writable directory. nv2.exe is not writeable since we wrapped everything in an exe using tclkit. The script may usually has an extension and this method replaces the extension with ".qw_options". */ } ::set ScriptPath [::sargs::get $sargs .script.path]; ::if {$ScriptPath eq ""} { ::qw::bug 314120080122081310 "[::qw::procname] - empty \".script.path\"."; } ::if {$::qw::control(case_sensitive)} { ::set Folder [::file dirname $ScriptPath]; } else { ::set Folder [::string tolower [::file dirname $ScriptPath]]; } #2.38.0 ::set Name [::file tail [::file dirname $ScriptPath]]; ::set Name [::file tail [::file rootname $ScriptPath]]; ::if {[::string first $::qw_program_path $Folder]==0} { ::set Folder [::string replace $Folder 0 [::expr {[::string length $::qw_program_path]-1}] $::qw_data]; } ::return [::file join $Folder $Name.qw_options]; } ::proc ::qw::script::run {sargs} { /* { ::qw::script::run allows the user to select an external script to run. A file selection window is displayed to collect the script to run. If the user doesn't select a script then we simply return. Otherwise we source the script using ::qw::script::source. We maintain an option file to store the path to the last script run for convenience, and also a list af most recently used files. NewViews scripts follow a protocol that allows them to be evaluated in their own unique namespaces so that multiple invocations of a script do not interfere with each other. The protocol also allows argument passing without the use of global variables, and it provides for scripts to clean up after themselves. However, the scripts that are run do not need to follow this protocol at all, and they are sourced as normal scripts. That is, the protocol does not impose a footprint of any kind on scripts that do not follow it. The options file contains a ::qw::structure. We find the option file based on the script path but unfortunately there are two cases. If the script is under the qw_library then the options file cannot be written because the the script is in a nopn-writable vfs. In that case the options file is in the same directory as the qw_script but with the qw_library part replaced by qw_options. Otherwise the options really are in the same directory as the script. 2.23.0 - changed .file_list to .mru_list - call file dialog based on tablelist which in turn uses mrulist dialog, also based on tablelist - default is now the first mru_list item */ } ::set OptionsFile [::file join $::qw_data system script_run.qw_options]; # If the drive letter in the path does not exist, then we just hang ... /* { ::while {$DefaultDirectory ne ""&&![::file exists $DefaultDirectory]} { ::set DefaultDirectory [::lrange [::file split $DefaultDirectory] 0 end-1]; } */ } ::set Options [::sargs::file::get $OptionsFile]; ::if {[::sargs::exists $Options .mru_list]} { ::set MruList [::sargs::get $Options .mru_list] } else { /* { 2.23.0 When we upgraded the file and mru_list dialog to tablelist, we changed the .file_list field to .mru_list. Here we change the field name in the options file. We also get rid of .path because from now on the default is the first element of the mru_list. */ } ::set MruList [::sargs::get $Options .file_list] ::sargs::var::unset Options .file_list; ::sargs::var::unset Options .path; ::set BuiltinList [::glob -nocomplain [::file join $::qw_data scripts *.qw_script*]]; ::foreach Element $BuiltinList { ::set MruList [::qw::list::demote .list $MruList .element $Element]; } } ::sargs::var::set Options .mru_list $MruList; ::sargs::file::set $OptionsFile $Options; ::set ResultStructure [::qw::dialog85::field_prompt \ .browse_type tk_getOpenFile \ .pattern_list [::list *.qw_script*] \ .title "Pick a script to run." \ .caption_title "Script File" \ .mru_list $MruList \ .help_page { .title "You are being asked to select a script." .id 314120060606102636 .tags "dialog" .body { [h2 "Running a NewViews script."] [p { You are being asked to select a script to run. NewViews scripts have the file type [qw_quoted [qw_directory .qw_script]]. In the [qw_field_name "Script File"] field enter the path to the script file and when ready, click [qw_button Ok]. }] [p { Click the button at the right end of the [qw_field_name "Script File"] field or press [qw_button F3] to pick from a list of most-recently run scripts. Or when the list is up, click on the [qw_button Browse] button to pick from a file explorer. You can [qw_button "double-click"] on the desired item or press [qw_key Enter] or [qw_key Spacebar] to select an item from the list or file explorer. }] } } ]; ::set SelectedScriptPath [::sargs::get $ResultStructure .result]; ::set MruList [::sargs::get $ResultStructure .mru_list]; ::if {$SelectedScriptPath eq ""} { ::sargs::file::set $OptionsFile .mru_list $MruList; ::return ""; } /* { #2.31.0 ::set SelectedScriptPath [::string tolower [::file normalize $SelectedScriptPath]]; file normalize turns a relative path into an absolute path which we really do not want to do. We want ::qw::script::source to process ::qw::script::auto_path to deal with relative paths. */ } /* { 2.31.0 - put script into the mrulist regardless of wheher it will be successful and let qw::script::source check for errors and also extend relative paths to absolute. Perhaps even mistakes should go into the mru list so they can be brought back and corrected. */ } ::set MruList [::qw::list::promote .list $MruList .element $SelectedScriptPath]; ::sargs::file::set $OptionsFile .mru_list $MruList; ::set Result [::qw::script::source $sargs .script.path $SelectedScriptPath]; ::return $Result; ::qw::try { ::if {![::file exists $SelectedScriptPath]} { ::qw::throw "Could not find file \"$SelectedScriptPath\"."; } ::if {![::file isfile $SelectedScriptPath]} { ::qw::throw "\"$SelectedScriptPath\" is not a file."; } } catch Exception { /* { If the specified file doesn't exist or isn't a file we simply remove it from the file list. */ } ::set Pos [::lsearch [::string tolower $MruList] [::string tolower $SelectedScriptPath]]; if {$Pos>=0} { ::set MruList [::lreplace $MruList $Pos $Pos]; ::sargs::file::set $OptionsFile .mru_list $MruList; } ::qw::throw $Exception; } # ::sargs::file::set $OptionsFile .path $SelectedScriptPath; ::return $Result; }