# ------------------------------------------------------------ # Copyright (c) 2012-2020 # Q.W.Page Associates Inc. # www.qwpage.com # All rights reserved. # ------------------------------------------------------------ ::namespace eval ::qw::fileutil {} ::set ::qw::fileutil::temporary_counter 0; ::proc ::qw::fileutil::recursive_glob {sargs} { /* { The recursive_glob proc from tclx did not seem to work on the vfs, virtual file system. I investigated and found that they use readdir which seems to be implemented low-level in c and bypasses the layer implementing vfs. Sample usage ::set Files [::qw::fileutil::recursive_glob .folder_list [::list $::qw_library] .pattern_list [::list *.dll]]; */ } ::set FolderList [::sargs::get $sargs .folder_list]; ::set PatternList [::sargs::get $sargs .pattern_list]; ::set IncludeFolders [::sargs::boolean_get $sargs .include_folders]; ::set Result [::list]; ::foreach Folder $FolderList { ::if {![::file exists $Folder]} { ::continue; } ::if {![::file isdirectory $Folder]} { ::qw::throw "[::qw::procname] - expected \"$Folder\" to be a folder."; } ::if {$IncludeFolders} { ::set Result [::concat $Result $FolderList]; } ::foreach Pattern $PatternList { ::set Result [::concat $Result [::glob -nocomplain -types f -- [::file join $Folder $Pattern]]] } ::set SubFolderList [::glob -nocomplain -types d -nocomplain -- [::file join $Folder *]]; ::if {[::llength $SubFolderList]!=0} { ::set KidList [[::qw::procname] $sargs .folder_list $SubFolderList]; ::foreach Path $KidList { ::if {[::file isfile $Path]} { ::lappend Result $Path; } } # ::set Result [::concat $Result [[::qw::procname] $sargs .folder_list $SubFolderList]]; } } ::return $Result; } /* { proc recursive_glob {dirlist globlist} { set result {} set recurse {} foreach dir $dirlist { if ![file isdirectory $dir] { error "\"$dir\" is not a directory" } foreach pattern $globlist { set result [concat $result \ [glob -nocomplain -- [file join $dir $pattern]]] } foreach file [readdir $dir] { set file [file join $dir $file] if [file isdirectory $file] { set fileTail [file tail $file] if {!([cequal $fileTail .] || [cequal $fileTail ..])} { lappend recurse $file } } } } if ![lempty $recurse] { set result [concat $result [recursive_glob $recurse $globlist]] } return $result } */ } ::proc ::qw::fileutil::header_read {sargs} { /* { 2.23.0 Templates are a list of records in the form of commands or even a big structure. Each "record" is a name/value pair where the name is a structure field name and the value is a structure. Within the structure is a .record_type field. This can be any value used by a specific application for a specific purpose, but we reserve the value "header" to identify the file header record. We need to extract the header so we can check the version before doing anything else. The import itself will throw an error if we attmept to import the wrong version. Sometimes we do want to throw an error but sometimes we just want to pretend the file did not exist and move on. */ } ::set InHandle [::sargs::get $sargs .file_handle]; ::if {$InHandle eq ""} { ::set File [::sargs::get $sargs .file_path]; ::if {$File eq ""} { ::qw::bug 314120120524103813 "[::qw::procname] - no file."; } ::if {![::file isfile $File]} { ::return ""; } ::set InHandle [::open $File r]; ::qw::finally [::list ::close $InHandle]; } ::set Buffer ""; ::while {[::gets $InHandle Line]>=0} { ::append Buffer $Line "\n"; ::if {$Line ne "\x7d"} { ::continue; } ::if {[::info complete $Buffer]} { ::if {[::llength $Buffer]==0} { ::continue; } ::if {[::lindex $Buffer 0] eq ""} { ::continue; } ::set Line $Buffer; ::set Buffer ""; ::if {[::llength $Line]!=2} { /* { Invalid syntax. The import throws an error here. We will instead behave as if there were no header. */ } ::return ""; } ::set Field [::lindex $Line 0]; ::set Record [::lindex $Line 1]; ::set RecordType [::sargs::get $Record .record_type]; ::sargs::var::unset Record .record_type; ::switch -- $RecordType { header { ::return $Record; } default { ::qw::bug 314120120329144547 "[::qw::procname] - invalid import record type \"$RecordType\"." } } } } ::return ""; } ::variable ::qw::fileutil::_temporary_folder ""; ::proc ::qw::fileutil::temporary_directory {} { /* { Returns the temporary directory as defined for the host platform. */ } ::if {$::qw::fileutil::_temporary_folder ne ""} { ::return $::qw::fileutil::_temporary_folder; } ::switch -- $::tcl_platform(platform) { unix { ::set ::qw::fileutil::_temporary_folder /tmp; # or even $::env(TMPDIR), at times. ::return $::qw::fileutil::_temporary_folder; } macintosh { ::set ::qw::fileutil::_temporary_folder $::env(TRASH_FOLDER);# a better place? ::return $::qw::fileutil::_temporary_folder; } windows { ::if {[::info exists ::env(TMP)]} { ::if {$::env(TMP) ne ""} { ::if {[::file writable $::env(TMP)]} { #::set TempPath [::file join $::env(TMP) qwpage_$::qw_build]; ::set TempPath [::file join $::env(TMP) qwpage]; ::if {![::file exists $TempPath]} { ::file mkdir $TempPath; } ::set ::qw::fileutil::_temporary_folder $TempPath; ::return $::qw::fileutil::_temporary_folder; } } } ::if {[::info exists ::env(TEMP)]} { ::if {$::env(TEMP) ne ""} { ::if {[::file writable $::env(TEMP)]} { #::set TempPath [::file join $::env(TEMP) qwpage_$::qw_build]; ::set TempPath [::file join $::env(TEMP) qwpage]; ::if {![::file exists $TempPath]} { ::file mkdir $TempPath; } ::set ::qw::fileutil::_temporary_folder $TempPath; ::return $::qw::fileutil::_temporary_folder; } } } ::if {[::file writable [::pwd]]} { ::set ::qw::fileutil::_temporary_folder [::pwd]; ::return $::qw::fileutil::_temporary_folder; } } } # This would be a good place to start searching volumes. ::qw::throw "[::qw::procname] - could not find temporary folder."; } ::proc ::qw::fileutil::temporary_directory_cleanup {} { /* { Does what it can to clean up the temporary directory. We clean out ../tmp. Since this directory is shared with a lot of junk from other programs, we only try to clean out the tclkit dlls (tcl*.tmp) and anything put there by the help system (~*.tmp). */ } ::set Directory [::file dirname [::qw::fileutil::temporary_directory]]; ::foreach Path [::glob -nocomplain \ [::file join $Directory qwpage *] \ [::file join $Directory qwpage bin *] \ [::file join $Directory *.tmp] \ ] { /* { We use catch instead of try/catch because errors generated by try/catch spray too many diagnostics into the lst file during debugging. */ } ::catch {::file delete -force -- $Path}; } # 2.28.0 /* { TclKit has been leaving folders such as TCLffa058bc in the temp folder. These are where TclKit downloads dll files from the vfs so they can be loaded from the host operating system. We think TclKit cleans up a bit on shutdown but doesn't get the chance on a crash. Development systems have built up many gigs due to the fact that they crash more often than the normal user system. So here we attempt to delete the temp TclKit folders. */ } ::foreach Path [::glob -nocomplain -types d [::file join $Directory TCL????????]] { /* { We use catch instead of try/catch because errors generated by try/catch spray too many diagnostistics into the lst file during debugging. */ } ::catch {::file delete -force -- $Path}; } } ::proc ::qw::fileutil::temporary_path {sargs} { /* { Finds an unused name within the specified directory and returns the full path. If the directory is not specified or is empty then we call ::qw::fileutil::temporary_directory .folder aaa .prefix xxx .suffix yyy Suppose specified suffix is ".chm". Then we return a unique file name with that extension. */ } ::set Directory [::sargs::get $sargs .directory]; ::if {$Directory eq ""} { /* { If directory is specified we find a unique name within it. Otherwise we do the same but in the default temporary dfirectory. */ } ::set Directory [::sargs::get $sargs .folder]; ::if {$Directory eq ""} { ::set Directory [::qw::fileutil::temporary_directory]; } } ::while {1} { ::set Accumulator ""; ::append Accumulator [::pid]; ::append Accumulator "_"; ::append Accumulator [::clock seconds]; ::append Accumulator "_"; ::append Accumulator [::clock clicks]; ::append Accumulator "_"; ::append Accumulator [::incr ::qw::fileutil::temporary_counter]; ::set Accumulator [::md5::md5 -hex $Accumulator]; ::set Name ""; ::append Name [::sargs::get $sargs .prefix]; ::append Name [::string range $Accumulator 0 15]; ::append Name [::sargs::get $sargs .suffix]; ::set Path [::file join $Directory $Name]; ::if {![::file exists $Path]} { ::break; } } ::return $Path; } ::proc ::qw::fileutil::delete_files_in_folder {sargs} { # ------------------------------------------------------------ # Delete *.tmp files in the specified folder. # ------------------------------------------------------------ /* { Usage: ::qw::fileutil::delete_files .folder $Folder .mask_list [::list *.tmp]; We could crash in which case the tmp file will not be cleaned up. We are not using the qw temp folder (complicates disk space checking) so instead, we garbage collect the destination folder here. */ } ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,delete_files_in_folder,1000.0,sargs==$sargs";} ::set Folder [::sargs::get $sargs .folder]; ::if {$Folder eq ""} { ::qw::bug 314120190829163417 "[::qw::procname] - no .folder argument."; } ::set MaskList [::sargs::get $sargs .mask_list]; ::if {$MaskList eq ""} { ::qw::bug 314120190829163418 "[::qw::procname] - no .mask_list argument."; } ::foreach Mask $MaskList { ::if {0} { ::if {[::string first ".tmp" $Mask]>=0} { # could this be why we are unable to load a dll under gnu 9.2? # turned out that it didn't make any difference ::continue; } } ::foreach Path [::glob -nocomplain \ [::file join $Folder $Mask] \ ] { ::qw::try { ::if {$rwb1_debug} {::puts "rwb1_debug,delete_files_in_folder,1000.1,Path==$Path";} ::file delete -force -- $Path; ::if {$rwb1_debug} {::puts "rwb1_debug,delete_files_in_folder,1000.2";} } catch Dummy { ::if {$rwb1_debug} {::puts "rwb1_debug,delete_files_in_folder,1000.3,Dummy==$Dummy";} } } } } /* { ::proc ::qw::fileutil::temporary_file {{prefix {}}} { /* { Creates an empty temporary file and returns its path. */ } ::set TmpDir [::qw::fileutil::temporary_directory]; set chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" set nrand_chars 10 set Tries 10 set access [list RDWR CREAT EXCL TRUNC] set permission 0600 set ProcessId [pid] ::for {::set i 0} {$i<$Tries} {::incr i} { ::set Name $prefix for {::set j 0} {$j<$nrand_chars} {incr j} { ::append Name [::string index $chars [::expr {([::clock clicks] ^ $ProcessId) % 62}]]; } ::set Name [::file join $TmpDir $Name] ::if {[::file exists $Name]} { # rwb - I have no idea why the delay. ::after 1 continue; } ::qw::try { ::close [::open $Name $access $permission]; ::return $Name; } catch Exception {} } ::qw::throw "::qw::fileutil::temporary_file could not find an unused temporary file name."; } */ } ::proc ::qw::fileutil::file_overwrite {sargs} { /* { This is only called once, from newviews definition. Was just copied to keep rth code working. */ } ::set Path [::sargs::get $sargs .path]; ::qw::try { ::if {$Path eq ""} { /* { Afraid to change rth's original specs. */ } ::return; } ::if {![::file exists $Path]} { /* { Afraid to change rth's original specs. */ } ::return; } ::switch -- $::tcl_platform(platform) { "windows" { ::if {[::file attributes $Path -readonly]} { ::qw::throw [::sargs \ .text "File \"$Path\" is read-only." \ .help_id ??? \ ]; } ::if {[::file attributes $Path -system]} { ::qw::throw [::sargs \ .text "File \"$Path\" is a system file." \ .help_id ??? \ ]; } ::if {![::file isfile $Path]} { ::qw::throw [::sargs \ .text "\"$Path\" is not a file." \ .help_id ??? \ ]; } } } ::file delete $Path; } catch Exception { ::qw::throw [::qw::exception::parent $Exception "Could not overwrite file \"$Path\"."]; } } ::proc ::qw::fileutil::mkdir {sargs} { ::set Path [::sargs::get $sargs .path]; ::if {$Path eq ""} { ::qw::throw "[::qw::procname] - no .path argument."; } ::if {![::file exists $Path]} { ::file mkdir $Path; ::return $Path; } ::if {![::file isdirectory $Path]} { /* { The object already exists so it had better be a folder. */ } ::qw::throw "[::qw::procname] - file \"$Path\" exists and is not a folder."; } ::return $Path; } ::proc ::qw::fileutil::+= {sargs} { /* { Usage: ::qw::fileutil::+= \ .destination_folder g:/d \ .source_folder d:/a/b/c \ .mask_list "" \ .skip_mask_list [::list *.bak *.obj] \ .folder_command ::some_folder_callback_proc .file_command ::some_file_callback_proc .copy_skip 0 \ .is_verbose 1 \ ; Copies all files in SrcDir to DstDir if they match a set of masks. Files and folders that exist in dst but not in src are not deleted. Returns a list of the files copied. Each file is a full path to the dst file. I figure the dst file is more useful than the src file. Before copying each file or folder the appropriate callback, if any, is called. This gives the caller an opportunity to display progress, for example. */ } ::set FileCallback [::sargs::get $sargs .file_command]; ::set FolderCallback [::sargs::get $sargs .folder_command]; ::set SrcDir [::sargs::get $sargs .source_folder]; ::set DstDir [::sargs::get $sargs .destination_folder]; ::set MaskList [::sargs::get $sargs .mask_list]; ::set CopySkip [::sargs::boolean_get $sargs .copy_skip]; ::if {$MaskList eq ""} { ::set MaskList [::list *]; } ::set SkipMaskList [::sargs::get $sargs .skip_mask_list]; ::qw::fileutil::mkdir .path $DstDir; ::set AbsoluteMaskList [::list]; ::foreach Mask $MaskList { ::lappend AbsoluteMaskList [::file join $SrcDir $Mask]; } ::set FileList [::list]; ::foreach SrcFile [::eval ::glob -nocomplain -types f -- $AbsoluteMaskList] { ::set Name [::file tail $SrcFile]; ::set Skip 0; ::foreach SkipMask $SkipMaskList { ::if {[::string match -nocase $SkipMask $Name]} { /* { This is so we can skip stuff like *.bak and *.obj. */ } ::set Skip 1; ::break; } } ::if {$Skip} { ::continue; } ::set DstFile [::file join $DstDir $Name]; ::if {[::file exists $DstFile]} { # 2.27.1 skip existing files added. ::if {[::file mtime $SrcFile]==[::file mtime $DstFile]} { /* { Skip the file if it exists and has not been modified. */ } ::continue; } } ::if {[::sargs::boolean_get $sargs .is_verbose]} { ::if {!$CopySkip} { ::qw::status::puts "Copying $DstFile <- $SrcFile"; } } ::if {$FileCallback ne ""} { ::uplevel #0 $FileCallback [::list \ .command copy \ .source_path $SrcFile \ .destination_path $DstFile \ ]; } ::if {!$CopySkip} { ::file copy -force $SrcFile $DstDir; } ::lappend FileList $DstFile; } ::foreach KidFolder [::eval ::glob -nocomplain -types d -- [::file join $SrcDir *]] { /* { Process sub-folders recursively. */ } ::if {$FolderCallback ne ""} { ::eval $FolderCallback [::list \ .source_path $KidFolder \ .destination_path [::file join $DstDir [::file tail $KidFolder]] \ ]; } ::set KidFileList [[::qw::procname] $sargs \ .source_folder $KidFolder \ .destination_folder [::file join $DstDir [::file tail $KidFolder]] \ .mask_list $MaskList \ ]; ::set Filelist [::concat $FileList $KidFileList]; } ::return $FileList; } ::proc ::qw::fileutil::file+= {sargs} { /* { 2.27.3 - added this proc. Just copies a single file. If we copy the file, returns 1. If the destination file exists and has the same date we skip it and return 0; .source_file .destination_file .file_command Before copying each file or folder the appropriate callback, if any, is called. This gives the caller an opportunity display progress, for example. */ } ::set FileCallback [::sargs::get $sargs .file_command]; ::set SrcFile [::sargs::get $sargs .source_file]; ::set DstFile [::sargs::get $sargs .destination_file]; ::if {[::file exists $DstFile]} { # skip existing files. ::if {[::file mtime $SrcFile]==[::file mtime $DstFile]} { /* { Skip the file if it exists and has not been modified. */ } ::return 0; } } ::if {$FileCallback ne ""} { ::eval $FileCallback [::list \ .command copy \ .source_path $SrcFile \ .destination_path $DstFile \ ]; } ::if {[::sargs::boolean_get $sargs .use_qw_file_copy]} { /* { Unfortunately we often copy files that contain a vfs and when we do, tcl thinks it is a folder. */ } [::qw::system] cpp_file_copy $sargs; # ::qw::file_copy $sargs; } else { ::file copy -force $SrcFile $DstFile; } ::return 1; } ::proc ::qw::fileutil::make_backup_folder_exist {sargs} { /* { Usage: ::qw::fileutil::make_backup_folder_exist \ .backup_folder c:/a/b/c \ .interactive_skip 0/1 \ ; 2.25.3 Make sure the folder exists and silently create folders if necessary. Report any failure as an exception. This was added for remote backups. It makes sure the folder exists silently because it could be called from a server and we simply can't ask the user on the workstation to confirm. The cpp_database_backup is low-level in c++ and it is remote-safe. Problem: Workstation asks if folder exists before calling cpp_database_backup. If folder does not exist it tries to create it. But if it succeeds the folder is created on the workstation, not the server. Even that failed when x:/ existed in the server but not the workstation because the attempt to create x:/ could not succeed on the workstations and failed with tcl message "can't create directory X:/: no such file or directory". Solution: Create the missing folder on the server. But this has to be called from the low-level cpp_database_backup because that's the level at which the remote call was implemented. We could implement a higher level alternative. The problem is that the origional code prompted the user if it was ok to create the folder. The only way to do this properly is to implement high level stuff on the workstation, but take low-level file work on the server and offer an interface to the workstation. Or else we just go ahead and create the backup folder and report an error if we can't. To make things easier we cut the code that does this out to tcl (i.e. here) and have the cpp_database_backup code (which will be with the database in server) call it. */ } ::set BackupFolder [::sargs::get $sargs .backup_folder]; ::set BackupFolder [::string trim $BackupFolder]; ::if {$BackupFolder eq ""} { ::qw::throw \ .text "The backup folder was not specified." \ .help_id ??? \ ; } ::if {[::file exists $BackupFolder]} { ::if {![::file isdirectory $BackupFolder]} { ::qw::throw \ .text "\"$BackupFolder\" is not a folder." \ .help_id ??? \ ; } ::if {![::file writable $BackupFolder]} { ::qw::throw \ .text "Cannot write to \"$BackupFolder\"." \ .help_id ??? \ ; } ::return 1; } ::if {![::sargs::boolean_get $sargs .interactive_skip]} { /* { For local database backup we allow the user to change the backup folder and it might not exist. If it doesn't, we ask the user if he wants to create the folder. */ } ::set Text ""; ::append Text "Folder \"$BackupFolder\" was not found."; ::append Text "\n\nClick to create a new folder and perform the backup.\n"; ::append Text "\nClick to dismiss this window without creating a backup."; ::set Result [::qw::dialog::confirm \ .title "Create Folder?" \ .text $Text \ .help.help_id 314120050220114148??? \ .help.folder [::sargs::get $sargs .database_path] \ /button/ok.text "Create Folder" \ ]; if {!$Result} { ::return 0; } } ::qw::try { ::file mkdir $BackupFolder; } catch Exception { ::qw::throw [::qw::exception::nest .sub "Operating system reported: $Exception" .super [::sargs \ .text "Could not create folder \"$BackupFolder\"." \ .help_id ??? \ ]]; } ::return 1; } ::proc ::qw::fileutil::make_folder_exist {sargs} { /* { Usage: ::qw::fileutil::make_folder_exist \ .folder c:/a/b/c \ .interactive_skip 0/1 \ ; Returns 1 in folder exist (could have been created), 0 otherwise. 2.34.0 This is the same as make_backup_folder_exist except it is generic for any folder. Mainly, we just wanted to take the word "backup" out of it so we could use it from more than one place, and we wanted to leave make_backup_folder_exist alone rather that introduce subtle problems. Exceptions can be thrown. If .interactive_skip is 0 then user is prompted whether to create the folder. Otherwise the folder is selently created. */ } ::set Folder [::sargs::get $sargs .folder_path]; ::set Folder [::string trim $Folder]; ::qw::try { ::if {$Folder eq ""} { ::qw::throw \ .text "The folder was not specified." \ .help_id ??? \ ; } ::if {[::file exists $Folder]} { ::if {![::file isdirectory $Folder]} { ::qw::throw \ .text "\"$Folder\" is not a folder." \ .help_id ??? \ ; } ::if {![::file writable $Folder]} { ::qw::throw \ .text "Cannot write to \"$Folder\"." \ .help_id ??? \ ; } ::return 1; } ::if {![::sargs::boolean_get $sargs .interactive_skip]} { # ------------------------------------------------------------ # Ask user to confirm folder creation. # ------------------------------------------------------------ ::set Text ""; ::append Text "Folder \"$Folder\" was not found."; ::append Text "\n\nClick to create folder \"$Folder\".\n"; ::append Text "\nClick to cancel the operation (no new folder)."; ::set Result [::qw::dialog::confirm \ .title "Create folder \"$Folder\"?" \ .text $Text \ /button/ok.text "Create Folder" \ .help_page [::subst -nocommands { .id 314120190828161349 .tags {error} .title "Folder $Folder not found. Create it?" .body { [p { A specified destination file is in folder [qw_directory {$Folder}] but that folder does not exist. This may be the result of a mistake or you may want this folder to be created right now. }] [p { Click [qw_button Ok] to create the missing folder and continue. }] [p { Click [qw_button Dismiss] to cancel the operation. This will let you correct the problem and try again. }] } }] \ ]; if {!$Result} { ::return 0; } } ::qw::fileutil::mkdir .path $Folder; ::return 1; } catch Exception { ::qw::throw [::qw::exception::nest .sub $Exception .super [::sargs \ .text "Could not create folder \"$Folder\"." \ .help_id ??? \ ]]; } } ::proc ::qw::fileutil::make_folder_exist_deprecated_with_interface {sargs} { /* { Usage: ::qw::fileutil::make_folder_exist \ .folder c:/a/b/c \ .interactive_skip 0/1 \ ; Returns 1 in folder exist (could have been created), 0 otherwise. 2.34.0 This is the same as make_backup_folder_exist except it is generic for any folder. Mainly, we just wanted to take the word "backup" out of it so we could use it from more than one place, and we wanted to leave make_backup_folder_exist alone rather that introduce subtle problems. Exceptions can be thrown. If .interactive_skip is 0 then user is prompted whether to create the folder. Otherwise the folder is selently created. */ } ::set Folder [::sargs::get $sargs .folder_path]; ::set Folder [::string trim $Folder]; ::qw::try { ::if {$Folder eq ""} { ::qw::throw \ .text "The folder was not specified." \ .help_id ??? \ ; } ::if {[::file exists $Folder]} { ::if {![::file isdirectory $Folder]} { ::qw::throw \ .text "\"$Folder\" is not a folder." \ .help_id ??? \ ; } ::if {![::file writable $Folder]} { ::qw::throw \ .text "Cannot write to \"$Folder\"." \ .help_id ??? \ ; } ::return 1; } ::if {![::sargs::boolean_get $sargs .interactive_skip]} { # ------------------------------------------------------------ # Ask user to confirm folder creation. # ------------------------------------------------------------ ::set Text ""; ::append Text "Folder \"$Folder\" was not found."; ::append Text "\n\nClick to create folder \"$Folder\".\n"; ::append Text "\nClick to cancel the operation (no new folder)."; ::set Result [::qw::dialog::confirm \ .title "Create folder \"$Folder\"?" \ .text $Text \ /button/ok.text "Create Folder" \ .help_page [::subst -nocommands { .id 314120190828161349 .tags {error} .title "Folder $Folder not found. Create it?" .body { [p { A specified destination file is in folder [qw_directory {$Folder}] but that folder does not exist. This may be the result of a mistake or you may want this folder to be created right now. }] [p { Click [qw_button Ok] to create the missing folder and continue. }] [p { Click [qw_button Dismiss] to cancel the operation. This will let you correct the problem and try again. }] } }] \ ]; if {!$Result} { ::return 0; } } ::qw::fileutil::mkdir .path $Folder; ::return 1; } catch Exception { ::qw::throw [::qw::exception::nest .sub $Exception .super [::sargs \ .text "Could not create folder \"$Folder\"." \ .help_id ??? \ ]]; } } ::proc ::qw::fileutil::file_read {sargs} { /* { ::set Data [::qw::file_read \ .path c:/ab/c.qw_help \ ?.translation translation_option? \ ?.encoding encoding_option? \ $.nocomplain 1? \ ]; This makes it easy to read a file without having to deal with handles. By default it reads text as opposed to binary, unless .translation is provided, and only in the current (system) char set of course. Returns "" if .nocomplain and anything at all goes wrong. */ } ::set rwb1_debug 0; ::set Path [::sargs::get $sargs .path]; ::if {$Path eq ""} { ::return ""; } ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::file_util::file_read,path==$Path"}; ::if {![::file exists $Path]} { ::if {[::sargs::boolean_get $sargs .nocomplain]} { ::return ""; } ::qw::throw \ .text "Can't find file \"$Path\"." \ .error_id 314120151209143952 \ ; } ::if {![::file isfile $Path]} { ::if {[::sargs::boolean_get $sargs .nocomplain]} { ::return ""; } ::qw::throw \ .text "Can't read \"$Path\", not a file." \ .error_id 314120151209143953 \ ; } ::qw::try { ::set Handle [::open $Path r]; ::qw::finally [::list ::close $Handle]; } catch Exception { ::if {[::sargs::boolean_get $sargs .nocomplain]} { ::return ""; } ::qw::throw \ .text "Can't read file \"$Path\", error:\"$Exception\"." \ .error_id 314120151209143954 \ ; } ::set Translation [::sargs::get $sargs .translation]; #2.31.2 changed from .transaction to .translation ::if {$Translation ne ""} { ::fconfigure $Handle -translation $Translation; #2.31.2 changed from .transaction to .translation } ::set Encoding [::sargs::get $sargs .encoding]; ::if {$Encoding ne ""} { ::fconfigure $Handle -encoding $Encoding; } ::qw::try { ::set Data [::read $Handle]; } catch Exception { ::if {[::sargs::boolean_get $sargs .nocomplain]} { ::return ""; } ::qw::throw \ .text "Can't read file \"$Path\", error:\"$Exception\"." \ .error_id 314120191125161644 \ ; } ::return $Data; } ::proc ::qw::fileutil::file_write {sargs} { /* { Usage: ::qw::fileutil::write .path $Path .data ?.nocomplain 1? ?.translation binary/auto/crlf/cr/lf? This makes it easy to write a file without having to deal with handles. It reads text as opposed to binary, and only in the current (system) char set of course. Returns "" if anything at all goes wrong. */ } ::set rwb1_debug 0; ::set Data [::sargs::get $sargs .data]; ::if {$Data eq ""} { ::if {![::sargs::exists $sargs .data]} { ::qw::throw \ .text "[::qw::procname] - no .data argument." \ .error_id 314120151209164351 \ ; } } ::set Path [::sargs::get $sargs .path]; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::file_util::file_write,path==$Path"}; ::if {$Path eq ""} { ::if {[::sargs::boolean_get $sargs .nocomplain]} { ::return; } ::qw::throw \ .text "[::qw::procname] - empty .path argument."; .error_id 314120151209164353 \ ; ::return; } ::qw::try { ::set Handle [::open $Path w+]; ::qw::finally [::list ::close $Handle]; } catch Exception { ::if {[::sargs::boolean_get $sargs .nocomplain]} { ::return; } ::qw::throw \ .text "Can't write file \"$Path\", error:\"$Exception\"." \ .error_id 314120151209164352 \ ; } ::set Translation [::sargs::get $sargs .translation]; ::if {$Translation ne ""} { ::fconfigure $Handle -translation $Translation; } ::set Encoding [::sargs::get $sargs .encoding]; ::if {$Encoding ne ""} { ::fconfigure $Handle -encoding $Encoding; } ::qw::try { ::if {[::sargs::boolean_get $sargs .newline]} { ::puts $Handle $Data; } else { ::puts -nonewline $Handle $Data; } } catch Exception { ::if {[::sargs::boolean_get $sargs .nocomplain]} { ::return ""; } ::qw::throw \ .text "Can't write file \"$Path\", error:\"$Exception\"." \ .error_id 314120201212174822 \ ; } } ::proc ::qw::fileutil::file_create {sargs} { /* { Usage: ::qw::fileutil::file_create .path $Path; Not necessary as file_write and file_append automatically create files. But made code more readable when creating and then appending in pieces. Returns "". */ } ::set rwb1_debug 0; ::set Path [::sargs::get $sargs .path]; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::file_util::file_write,path==$Path"}; ::if {$Path eq ""} { ::if {[::sargs::boolean_get $sargs .nocomplain]} { ::return; } ::qw::throw \ .text "[::qw::procname] - empty .path argument."; .error_id 314120200913125846 \ ; ::return; } ::qw::try { ::set Handle [::open $Path w+]; ::qw::finally [::list ::close $Handle]; } catch Exception { ::if {[::sargs::boolean_get $sargs .nocomplain]} { ::return; } ::qw::throw \ .text "Can't create file \"$Path\", error:\"$Exception\"." \ .error_id 314120200913125847 \ ; } } ::proc ::qw::fileutil::file_append {sargs} { /* { Usage: ::qw::fileutil::file_append .data xxx ?.nocomplain 1? ?.translation binary/auto/crlf/cr/lf? This makes it easy to write a file without having to deal with handles. It reads text as opposed to binary, and only in the current (system) char set of course. Returns "" if anything at all goes wrong. */ } ::set rwb1_debug 0; ::set Data [::sargs::get $sargs .data]; ::if {$Data eq ""} { ::if {![::sargs::exists $sargs .data]} { ::qw::throw \ .text "[::qw::procname] - no .data argument." \ .error_id 314120200406111215 \ ; } } ::set Path [::sargs::get $sargs .path]; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::file_util::file_append,path==$Path"}; ::if {$Path eq ""} { ::if {[::sargs::boolean_get $sargs .nocomplain]} { ::return; } ::qw::throw \ .text "[::qw::procname] - empty .path argument."; .error_id 314120200406111216 \ ; ::return; } ::qw::try { ::set Handle [::open $Path a+]; ::qw::finally [::list ::close $Handle]; } catch Exception { ::if {[::sargs::boolean_get $sargs .nocomplain]} { ::return; } ::qw::throw \ .text "Can't append to file \"$Path\", error:\"$Exception\"." \ .error_id 314120200406111217 \ ; } ::set Translation [::sargs::get $sargs .translation]; ::if {$Translation ne ""} { ::fconfigure $Handle -translation $Translation; } ::set Encoding [::sargs::get $sargs .encoding]; ::if {$Encoding ne ""} { ::fconfigure $Handle -encoding $Encoding; } ::qw::try { ::if {[::sargs::boolean_get $sargs .newline]} { ::puts $Handle $Data; } else { ::puts -nonewline $Handle $Data; } } catch Exception { ::if {[::sargs::boolean_get $sargs .nocomplain]} { ::return ""; } ::qw::throw \ .text "Can't write file \"$Path\", error:\"$Exception\"." \ .error_id 314120201212174823 \ ; } } ::proc ::qw::fileutil::select_files {sargs} { /* { Usage: ::set FileList [::qw::fileutil::select_files .folder c:/a/b/c]; Returns a list of absolute file paths for all files under the given folder. Returns empty if there is no such folder. This is basically a helper function because ::qw::fileutil::recursive_glob could have been used directly. */ } ::set Folder [::sargs::get $sargs .folder]; ::if {$Folder eq ""} { ::if {![::sargs::exists $sargs .folder]} { ::qw::bug 314120160707091301 "[::qw::procname] - no .folder argument."; } ::return ""; } ::if {![::file exists $Folder]} { ::return ""; } ::if {![::file isdirectory $Folder]} { ::return ""; } ::set FileList [::qw::fileutil::recursive_glob .folder_list [::list $Folder] .pattern_list [::list *]]; ::return $FileList; } ::proc ::qw::fileutil::intersect3 {sargs} { /* { Usage: ::set Result3 [::qw::fileutil::intersect3 .folder1 c:/a/b/c .folder2 d:/a/b/c]; Gets the list of file paths under each folder and returns their intersect3, a list of three lists. Element 0 are files in folder1 but not folder2. Element 2 is files in folder2 but not folder1. Element 1 is files in both. The files are considered to be the same, and thus are returned in the middle element, if they have the same relative paths from their respective folders. Note - relative paths are returned. We have to do this because otherwise what is the meaning of the lements in the middle list? The caller has to re-join the relative path with the appropriate folder. */ } ::if {![::sargs::exists $sargs .folder1]} { ::qw::bug 314120160707091302 "[::qw::procname] - no .folder1 argument."; } ::if {![::sargs::exists $sargs .folder2]} { ::qw::bug 314120160707091303 "[::qw::procname] - no .folder2 argument."; } ::set Folder1 [::sargs::get $sargs .folder1]; ::set Folder1 [::string tolower $Folder1]; ::set Folder2 [::sargs::get $sargs .folder2]; ::set Folder2 [::string tolower $Folder2]; ::set AbsFileList1 [::qw::fileutil::select_files .folder $Folder1]; ::set AbsFileList1 [::string tolower $AbsFileList1]; ::set AbsFileList2 [::qw::fileutil::select_files .folder $Folder2]; ::set AbsFileList2 [::string tolower $AbsFileList2]; ::set RelFileList1 [::list]; ::foreach Path $AbsFileList1 { ::set Path1 [::string map [::list $Folder1 ""] $Path]; ::switch -- [::string index $Path1 0] { "/" - "\\" { # string leading slash or backslash to make path suitable for file join ::set Path1 [::string range $Path1 1 end]; } } ::lappend RelFileList1 $Path1; } ::set RelFileList2 [::list]; ::foreach Path $AbsFileList2 { ::set Path2 [::string map [::list $Folder2 ""] $Path]; ::switch -- [::string index $Path2 0] { "/" - "\\" { # string leading slash or backslash to make path suitable for file join ::set Path2 [::string range $Path2 1 end]; } } ::lappend RelFileList2 $Path2; } ::set Intersect3 [::qw::intersect3 $RelFileList1 $RelFileList2]; ::return $Intersect3; } ::proc ::qw::fileutil::disk_freespace {sargs} { /* { Usage: ::set Freespace [::qw::fileutil::disk_freespace .path c:/a/b/c.xxx]; Should be called with an absolute path. */ } ::set rwb1_debug 0; ::switch -- $::tcl_platform(platform) { windows { # drop through to windows twapi code } unix { /* { Don't have the unix code yet so just return a big number, i.e. 1 terabyte. */ } ::return [::expr wide(1024)*wide(1024)*wide(1024)*wide(1024)]; } } ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::fileutil::disk_freespace,1000.0,sargs==$sargs";} ::set Path [::sargs::get $sargs .path]; ::if {$Path eq ""} { ::set Path [::pwd]; } ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::fileutil::disk_freespace,1000.1,path==$Path";} /* { The ::file normalize call turns a relative or volumerelative path into an absolute path. It's the disk we need for the call to twapi::get_volume_info. */ } ::set Path [::file normalize $Path]; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::fileutil::disk_freespace,1000.2,path==$Path";} ::set Drive $Path; ::while {$Drive ne [::file dirname $Drive]} { /* { This loop distills the drive out of the path. */ } ::set Drive [::file dirname $Drive]; } ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::fileutil::disk_freespace,1000.3,Drive==$Drive";} ::set Freespace [::lindex [::twapi::get_volume_info $Drive -freespace] 1]; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::fileutil::disk_freespace,1000.4,Freespace==$Freespace";} #::set UserAvail [::lindex [::twapi::get_volume_info $Drive -useravail] 1]; ::return $Freespace; } ::itcl::class ::qw::fileutil::server_side_file_sender { # ------------------------------------------------------------ # Sends a file to client in chunks. # ------------------------------------------------------------ protected variable _server_side_file_path ""; protected variable _server_side_file_handle ""; protected variable _server_side_file_size 0; # 2.34.2 method server_side_sender_destroy {} { ::itcl::delete object $this; } destructor { ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,server_side_file_sender,destructor,1000.0";} ::if {$_server_side_file_handle ne ""} { ::qw::try { ::if {$rwb1_debug} {::puts "rwb1_debug,server_side_file_sender,destructor,1000.1";} ::close $_server_side_file_handle; ::set _server_side_file_handle ""; ::if {$rwb1_debug} {::puts "rwb1_debug,server_side_file_sender,destructor,1000.2";} } catch dummy { ::if {$rwb1_debug} {::puts "rwb1_debug,314120190826150022,could not close $_server_side_file_handle,exception==$dummy";} } } ::if {$rwb1_debug} {::puts "rwb1_debug,server_side_file_sender,destructor,1000.3";} ::qw::fileutil::delete_files_in_folder .folder [::file dirname $_server_side_file_path] .mask_list [::list *.tmp]; ::if {$rwb1_debug} {::puts "rwb1_debug,server_side_file_sender,destructor,1000.99";} } method main {sargs} { ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,server_side_file_sender,main,1000.0";} ::set _server_side_file_path [::sargs::get $sargs .server_side_file_path]; ::set _server_side_file_handle [::open $_server_side_file_path r]; ::set _server_side_file_size [::file size $_server_side_file_path]; ::fconfigure $_server_side_file_handle -translation binary; ::if {$rwb1_debug} {::puts "rwb1_debug,server_side_file_sender,main,1000.99";} } method server_side_send_next_chunk {sargs} { /* { Sends a chunk of the file, usually 1MB as specified by the client caller. Wraps it in base64 first. sends { .base64_size 999 .base64_data {...} } Note that the file can have less than ChunkSize left but we always send what we can. The client knows the file size and knows what to expect. */ } ::set rwb1_debug 0; ::if {$::qw::verbose(update)} { ::set rwb1_debug 2; } ::if {$rwb1_debug} {::puts "rwb1_debug,server_side_send_next_chunk,main,1000.0,app_name==$::qw::control(app_name),sargs==$sargs";} ::set BlobType [::sargs::get $sargs .blob_type]; ::set ChunkSize [::sargs::integer_get $sargs .chunk_size]; ::switch -- $BlobType { "blob_type_binary" { /* { .binary_blob_size and .binary_blob_data are placed directly in the result which is then returned. The ::read statement does not return the number of bytes that were actually read. To detemine this we get the seeks before and after the read and take the difference. */ } ::if {$rwb1_debug} {::puts "rwb1_debug,1000.1,app_name==$::qw::control(app_name)";} ::if {!$::qw::control(binary_blob_is_enabled)} { ::qw::bug 314120200126125951 "[::qw::methodname] - binary blob is not enabled."; } ::set SeekBefore [::tell $_server_side_file_handle]; ::set BinaryBlobData [::read $_server_side_file_handle $ChunkSize]; ::set SeekAfter [::tell $_server_side_file_handle]; ::set SizeRead [::expr {$SeekAfter-$SeekBefore}]; ::sargs::var::set Result .binary_blob_size $SizeRead; ::sargs::var::set Result .binary_blob_data $BinaryBlobData; ::if {$rwb1_debug} {::puts "rwb1_debug,server_side_send_next_chunk,main,1000.99.0";} ::return $Result; } "" - "blob_type_base64" { ::if {$rwb1_debug} {::puts "rwb1_debug,1000.2,app_name==$::qw::control(app_name)";} ::set BinaryData [::read $_server_side_file_handle $ChunkSize]; ::set Base64Data [::qw::base64::encode .data $BinaryData]; ::sargs::var::set Result .base64_size [::string length $Base64Data]; ::sargs::var::set Result .base64_data $Base64Data; ::if {$rwb1_debug} {::puts "rwb1_debug,server_side_send_next_chunk,main,1000.99.1";} ::return $Result; } } /* { No blob type was specified so just place base64 code in sargs. This is for compatibility with pre-2.34.1 releases. */ } ::qw::bug 314120200126125425 "[::qw::methodname] - invalid blob_type \"$BlobType\"."; } } ::itcl::class ::qw::fileutil::server_side_file_receiver { # ------------------------------------------------------------ # Receives a chunk from client and appends it to destination file. # ------------------------------------------------------------ protected variable _server_side_file_path ""; protected variable _server_side_temp_file_path ""; protected variable _server_side_temp_file_handle ""; method server_side_receiver_destroy {} { ::itcl::delete object $this; } destructor { ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,server_side_file_receiver,destructor,1000.0";} ::if {$_server_side_tempt_file_handle ne ""} { ::qw::try { ::if {$rwb1_debug} {::puts "rwb1_debug,server_side_file_receiver,destructor,1000.1";} ::close $_server_side_temp_file_handle; ::set _server_side_temp_file_handle ""; ::if {$rwb1_debug} {::puts "rwb1_debug,server_side_file_receiver,destructor,1000.2";} } catch dummy { ::if {$rwb1_debug} {::puts "rwb1_debug,314120190826150022,could not close $_server_side_file_handle,exception==$dummy";} } } ::qw::fileutil::delete_files_in_folder .folder [::file dirname $_server_side_file_path] .mask_list [::list *.tmp]; } method main {sargs} { ::set rwb1_debug 0; # ------------------------------------------------------------ # Make sure destination folder exists. # ------------------------------------------------------------ ::set _server_side_file_path [::sargs::get $sargs .server_side_file_path]; ::set DestinationFolder [::file dirname $_server_side_file_path]; ::if {![::qw::fileutil::make_folder_exist .folder_path [::file dirname $_server_side_file_path]]} { server_side_receiver_destroy; ::qw::throw "Can't create folder [::file dirname $_server_side_file_path]"; } ::qw::fileutil::delete_files_in_folder .folder [::file dirname $_server_side_file_path] .mask_list [::list *.tmp]; # ------------------------------------------------------------ # Create/open the server side temp file. # ------------------------------------------------------------ ::set Count 0; ::while {1} { /* { */ } ::set _server_side_temp_file_path [::file rootname $_server_side_file_path]_upload_$Count.tmp; ::if {![::file exists $_server_side_temp_file_path]} { ::break; } ::incr Count; } ::set _server_side_temp_file_handle [::open $_server_side_temp_file_path w+]; ::fconfigure $_server_side_temp_file_handle -translation binary; } method server_side_completed {sargs} { ::set Exception ""; ::qw::try { # ------------------------------------------------------------ # Close temp file and set its atime/mtime. # ------------------------------------------------------------ ::close $_server_side_temp_file_handle; ::set _server_side_temp_file_handle ""; ::file mtime $_server_side_temp_file_path [::sargs::get $sargs .client_side_mtime]; ::file atime $_server_side_temp_file_path [::sargs::get $sargs .client_side_atime]; ::if {[::file exists $_server_side_file_path]} { # ------------------------------------------------------------ # Delete the destination file if it exists. # ------------------------------------------------------------ ::file delete $_server_side_file_path; } # ------------------------------------------------------------ # Rename temp file to destination file. # ------------------------------------------------------------ ::file rename $_server_side_temp_file_path $_server_side_file_path; } catch Exception { } # ------------------------------------------------------------ # Commit suicide. # ------------------------------------------------------------ server_side_receiver_destroy; ::if {$Exception ne ""} { ::qw::throw $Exception; } ::return; } method server_side_receive_next_chunk {sargs} { # ------------------------------------------------------------ # Receives a chunk and appends it to the temp destination file. # ------------------------------------------------------------ ::qw::try { ::set Base64Size [::sargs::get $sargs .base64_size]; ::set Base64Data [::sargs::get $sargs .base64_data]; ::if {$Base64Size!=[::string length $Base64Data]} { ::qw::throw \ .text "Encountered a transmission error." .base64_size $Base64Size \ .string_length [::string length $Base64Data] \ ; } ::set Data [::qw::base64::decode .data $Base64Data]; ::qw::try { ::puts -nonewline $_server_side_temp_file_handle $Data; ::flush $_server_side_temp_file_handle; } catch Exception { ::qw::throw "Can't write to server file: $Exception"; } } catch Exception { server_side_receiver_destroy; ::qw::throw $Exception; } ::return; } } ::proc ::qw::fileutil::byte_order_mark {sargs} { /* { Usage: ::set Encoding [::qw::fileutil::byte_order_mark .path $FilePath]; This usage returns the encoding if found. It opens and closes the file. returns one of: utf-8 utf-16be utf-16le utf-32be utf-32le "" - Usage: ::set Encoding [::qw::fileutil::byte_order_mark .handle $FileHandle]; This usage takes a file handle opened for reading. It changes the file's encoding, if it can, and returns the encoding for information only. It leaves the file open at seek position 0, ready the read using the encoding. If it detects and encoding that it can't use, i.e. anything other than utf-8 at this time, then it throws an exception. returns one of: utf-8 - encoding utf-8 set on handle utf-16be - throw exception - don't know what encoding would be utf-16le - dido utf-32be - dido utf-32le - dido "" - no encoding, handle not modified BOM - byte order mark EF BB BF - UTF-8 FE EF - UTF-16 big-endian utf-16be FF FE - UTF-16 little endian utf-16le 00 00 FE FF - UTF-32 big-endian utf-32be FF FE 00 00 - UTF-32 little endian utf-32le EF==-17 or 239 FE==-2 or 254 BB==-69 or 187 BF==-65 or 191 FF==-1 or 255 https://unicode.org/faq/utf_bom.html Provides a great FAQ for unicode, bom, etc. Problem: tcl 8.4 does not have the "U" option on "c" format so when in tcl 8.4 we have to deal with negative numbers. 2.34.0 This proc was added because /tools/import records encountered and exported .csv file with a BOM for utf-8 at the fornt. */ } ::set WasGivenHandle 0; ::set Handle [::sargs::get $sargs .file_handle]; ::if {$Handle ne ""} { ::set WasGivenHandle 1; ::set Translation [::fconfigure $Handle -translation]; ::qw::finally [::list ::fconfigure $Handle -translation $Translation]; # ::qw::finally [::list ::seek $Handle 0]; } else { ::set Path [::sargs::get $sargs .file_path]; ::if {$Path eq ""} { ::qw::bug 314120191120134335 "[::qw::procname] - no .file_path or .file_handle argument."; } ::qw::try { ::set Handle [::open $Path r]; } catch Exception { ::qw::throw "Can't open \"$Path\". Exception: $Exception"; } /* { We were given path, not handle. We opened the file so we must close it. */ } ::qw::finally [::list ::close $Handle]; } ::fconfigure $Handle -translation binary; ::set Bytes [::read $Handle 4]; ::set CharList [::list]; ::if {$::tcl_version>=8.6} { ::binary scan $Bytes cu4 CharList; } else { ::binary scan $Bytes c4 CharList0; ::foreach Char $CharList0 { ::lappend CharList [::expr ($Char+0x100)%0x100]; } } ::if {$WasGivenHandle} { ::if {[::lrange $CharList 0 2] eq "239 187 191"} { ::set Encoding "utf-8"; ::fconfigure $Handle -encoding $Encoding; ::seek $Handle 3; ::return $Encoding; } ::if {[::lrange $CharList 0 1] eq "254 255"} { ::set Encoding "utf-16be"; ::qw::throw "Detected unicode encoding \"$Encoding\" but cannot process it."; } ::if {[::lrange $CharList 0 1] eq "255 254"} { ::set Encoding "utf-16le"; ::qw::throw "Detected unicode encoding \"$Encoding\" but cannot process it."; } ::if {[::lrange $CharList 0 3] eq "0 0 254 255"} { ::set Encoding "utf-32be"; ::qw::throw "Detected unicode encoding \"$Encoding\" but cannot process it."; } ::if {[::lrange $CharList 0 3] eq "255 254 0 0"} { ::set Encoding "utf-32le"; ::qw::throw "Detected unicode encoding \"$Encoding\" but cannot process it."; } ::seek $Handle 0; ::return ""; } /* { Don't need to fix seek position because we open/close the file. */ } ::if {[::lrange $CharList 0 2] eq "239 187 191"} { ::return "utf-8"; } ::if {[::lrange $CharList 0 1] eq "254 255"} { ::return "utf-16be"; } ::if {[::lrange $CharList 0 1] eq "255 254"} { ::return "utf-16le"; } ::if {[::lrange $CharList 0 3] eq "0 0 254 255"} { ::return "utf-32be"; } ::if {[::lrange $CharList 0 3] eq "255 254 0 0"} { ::return "utf-32le"; } ::return ""; } ::proc ::qw::fileutil::install_executable_file_name {sargs} { /* { Constructs the file name of the install.exe, given the release, subproduct and platform. */ } ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,install_executable_file_name,1000.0,sargs==$sargs";} ::set Release [::sargs::get $sargs .release]; ::if {$Release eq ""} { ::set Release $::qw_release; } ::set SubProduct [::sargs::get $sargs .sub_product]; ::if {$SubProduct eq ""} { ::set SubProduct $::qw_sub_product; } ::set Platform [::sargs::get $sargs .platform]; ::if {$Platform eq ""} { ::set Platform $::tcl_platform(platform); } ::switch -- $SubProduct,$Platform { "nph,windows" { ::if {$rwb1_debug} {::puts "rwb1_debug,install_executable_file_name,1000.1";} ::set FileName nv${Release}-win32-ix86-nph.exe; } "crm,windows" { ::if {$rwb1_debug} {::puts "rwb1_debug,install_executable_file_name,1000.2";} ::set FileName nv${Release}-win32-ix86-crm.exe; } "npm,windows" { ::if {$rwb1_debug} {::puts "rwb1_debug,install_executable_file_name,1000.3";} ::set FileName nv${Release}-win32-ix86-npm.exe; } "nv2,windows" { ::if {$rwb1_debug} {::puts "rwb1_debug,install_executable_file_name,1000.4";} ::set FileName nv${Release}-win32-ix86-nv2.exe; } "nph,unix" { ::if {$rwb1_debug} {::puts "rwb1_debug,install_executable_file_name,1000.5";} ::set FileName nv${Release}-linux-ix86-nph; } "crm,unix" { ::if {$rwb1_debug} {::puts "rwb1_debug,install_executable_file_name,1000.6";} ::set FileName nv${Release}-linux-ix86-crm; } "npm,unix" { ::if {$rwb1_debug} {::puts "rwb1_debug,install_executable_file_name,1000.7";} ::set FileName nv${Release}-linux-ix86-npm; } "nv2,unix" { ::if {$rwb1_debug} {::puts "rwb1_debug,install_executable_file_name,1000.8";} ::set FileName nv${Release}-linux-ix86-nv2; } default { /* { */ } ::if {$rwb1_debug} {::puts "rwb1_debug,install_executable_file_name,1000.9,SubProduct,Platform==$SubProduct,$Platform";} ::return ""; } } ::if {$rwb1_debug} {::puts "rwb1_debug,install_executable_file_name,1000.99,filename==$FileName";} ::return $FileName; } ::proc ::qw::fileutil::redirect_stdout {sargs} { /* { Usage: ::qw::fileutil::redirect_stdout .app_name $AppName; 2.34.9 - this method added to replace ad hoc redirects Called from stub, hub and node. Overrides puts to append to file whose name is based on nameofexecutable. We also put out a header which be useful for detecting when the message_database was restarted, etc. */ } ::set AppName [::sargs::get $sargs .app_name]; ::rename ::puts ::puts_qw; ::proc ::puts {args} { ::switch -- [::llength $args] { 1 { ::qw::cpp_puts [::lindex $args 0]; ::return [::lindex $args 0]; } 2 { ::if {[::lindex $args 0] eq "-nonewline"} { ::qw::cpp_puts_nonewline [::lindex $args 1]; ::return [::lindex $args 1]; } } } ::return [::eval ::puts_qw $args]; } ::puts ""; ::puts "----------------------------------------------------------------"; ::puts " app_name:$AppName"; ::puts " release:$::qw_release"; # 2.38.4 ::puts "executable:[::info nameofexecutable]"; ::puts " date:[::clock format [::clock seconds] -format {%H:%M:%S %d-%b-%Y}]"; ::puts " ymdhms:[::clock format [::clock seconds] -format {%Y%m%d%H%M%S}]"; ::puts " ::argv:$::argv"; ::puts "::qw_sargv:[::sargs::normalize $::qw_sargv]"; ::puts "----------------------------------------------------------------"; } ::proc ::qw::fileutil::create_duplicate_executable {sargs} { /* { Usage: ::qw::fileutil::create_duplicate_executable ?.source_path $SrcPath? .destination_path $DstPath; If you specify a file name that has no path, then the path is assumed to be the program folder. By default, creates a copy of the currently running executable with the specified name. The executable is created in the program folder. If the executable already exists it is first deleted, if possible. If not possible we issue a warning and continue. This is used by programs that launch other programs. The same executable could be used in all cases but instead we want to be able to monitor the running processes in the task manager and by naming them we can keep track. Note that deleting/copying executables is an efficiency hit but generally not material to overall performance. We have to use cpp_file_size and cpp_file_mtime because we are often dealing with the program executable which the "::file size" and "::file mtime" commands in the tcl virtual file system would treat as a vfs directory, not a host file. */ } ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,create_duplicate_executable,1000.0,sargs==$sargs";} ::if {$rwb1_debug} { ::set Milli [::clock clicks -milliseconds]; } ::set SrcPath [::sargs::get $sargs .source_path]; ::if {$SrcPath eq ""} { ::set SrcPath [::info nameofexecutable]; } ::if {[::file tail $SrcPath] eq $SrcPath} { /* { If no path is specified then the path is set to the program folder. */ } ::set SrcPath [::file join [::file dirname [::info nameofexecutable]] $SrcPath] } ::if {$rwb1_debug} {::puts "rwb1_debug,create_duplicate_executable,1000.1";} ::set DstPath [::sargs::get $sargs .destination_path]; ::if {[::file tail $DstPath] eq $DstPath} { /* { If no path is specified then the path is set to the program folder. */ } ::set DstPath [::file join [::file dirname [::info nameofexecutable]] $DstPath] ::if {$rwb1_debug} {::puts "rwb1_debug,create_duplicate_executable,1000.2,DstPath==$DstPath";} } /* { We have to use cpp_file_mtime and cpp_file_size instead of "::file mtime" and "::file size" because the src will most oftem be the executable path, which the tcl commands treat as the folder containing the VFS. We have to treat is as a regular host file. */ } ::set SrcTimeStamp [[::qw::system] cpp_file_mtime .path $SrcPath]; ::if {$rwb1_debug} {::puts "rwb1_debug,create_duplicate_executable,1000.3";} ::if {[::file exists $DstPath]} { ::set DstTimeStamp [[::qw::system] cpp_file_mtime .path $DstPath]; /* { If the file size and timestamp are equal, do nothing. */ } ::set SrcSize [[::qw::system] cpp_file_size .path $SrcPath]; ::set DstSize [[::qw::system] cpp_file_size .path $DstPath]; ::if {$rwb1_debug} {::puts "rwb1_debug,create_duplicate_executable,1000.3.0,SrcSize==$SrcSize,DstSize==$DstSize,SrcTimeStamp==$SrcTimeStamp,DstTimeStamp==$DstTimeStamp";} ::if {$SrcSize==$DstSize&&$SrcTimeStamp==$DstTimeStamp} { ::if {$rwb1_debug} {::puts "[::qw::procname] - size and time stamp match,DstPath==$DstPath";} ::return; } ::if {$DstTimeStamp!=0&&$SrcTimeStamp!=0} { ::if {$DstTimeStamp>=$SrcTimeStamp} { /* { 2.38.2 When running as a windows service, the timestamp might come back as a zero which screws up the comparison. So if either timestamp is zero we just delete the file and replace it. Otherwise, if the destination file exists and it's timestamp is after the source file's timestamp, then leave it alone. It has been replaced by the "outside world" and they undoubtably want it to stay that way. Rationale: We now ensure set the destination file is set to the same date as the source file. This was found necessary when we added the ability to replace a stub executable without shutting any hubs or nodes. In the past, the checker was always overwriting the stub with itself, defeating the ability to replace the stub. Now this fileutil proc will not replace the destination file (i.e. the stub) if the destination file has a date greater than the source file (the checker). */ } ::if {$rwb1_debug} {::puts "rwb1_debug,create_duplicate_executable,1000.4,DstTimeStamp==$DstTimeStamp,SrcTimeStamp==$SrcTimeStamp";} ::return; } } ::qw::try { /* { Why delete the file if it exists? The answer is that this ensures that the dupicate executable will always be the same version as the current executable. Otherwise we'll have big but subtle problems. The efficency hit is not material. */ } ::if {$rwb1_debug} {::puts "rwb1_debug,create_duplicate_executable,1000.5,DstPath==$DstPath";} ::file delete $DstPath; ::if {$rwb1_debug} {::puts "rwb1_debug,create_duplicate_executable,1000.6";} } catch Exception { /* { If the file exists and we can't delete it we move on. Actually I can't understand how this could happen except for some obscure timing thing, but it did happen. If we can't delete the executable then we leave it alone and run it anyway. */ } ::if {$rwb1_debug} {::puts "rwb1_debug,create_duplicate_executable,1000.7,Exception==$Exception";} ::qw::warning 314120230828161941 "Could not delete $DstPath,Exception:$Exception"; ::return; } ::if {[::file exists $DstPath]} { ::qw::bug 314120240828104319 "Deleted file \"$DstPath\" but file continues to exist."; } } /* { 2.38.2 Before 2.38.2, cpp_file_copy in linux did not set the dst file to the same date as the src file. Now it does. Windows cpp_file_copy always did. */ } ::if {$rwb1_debug} {::puts "rwb1_debug,create_duplicate_executable,1000.8,SrcPath==$SrcPath,DstPath==$DstPath";} ::qw::try { [::qw::system] cpp_file_copy .source_file $SrcPath .destination_file $DstPath; } catch Exception { ::qw::warning 314120240828105231 "[::qw::procname] - Could not overwrite \"$DstPath\"."; ::qw::throw $Exception; } ::if {$rwb1_debug} {::puts "rwb1_debug,create_duplicate_executable,1000.9,SrcPath==$SrcPath,DstPath==$DstPath";} ::qw::try { ::file mtime $DstPath $SrcTimeStamp; } catch Exception { ::qw::warning 314120240828105232 "[::qw::procname] - Could not set mtime on file \"$DstPath\"."; ::qw::throw $Exception; } /* { 50 MB non-release took about 100 ms on benn_2020. */ } ::if {$rwb1_debug} {::puts "rwb1_debug,create_duplicate_executable,1000.10,Milli==[::expr {[::clock clicks -milliseconds]-$Milli}]";} } ::proc ::qw::fileutil::file_open_count {sargs} { ::set rwb1_debug 0; ::set DatabasePath [::sargs::get $sargs .database_path]; ::if {$DatabasePath eq ""} { ::qw::bug 314120241108151814 "[::qw::procname] - invalid database_path \"$DatabasePath\"."; } ::switch -- $::tcl_platform(platform) { "windows" { ::qw::warning 314120241108095855 "[::qw::procname] - not implemented on windows." ::return 0; } "unix" { /* { Uses unix lsof to find out how many times an executable is running. */ } # ::set TaskData [::exec [::list lsof $DatabasePath | grep $DatabasePath]]; # ::set TaskData [::exec [::list lsof $DatabasePath]]; ::if {$rwb1_debug} { ::set Milli0 [::clock clicks -milliseconds]; } ::set TaskData [::exec lsof]; ::if {$rwb1_debug} { ::set Milli1 [::expr {[::clock clicks -milliseconds]-$Milli0}]; } ::set OpenCount 0; ::set LineLength [::llength [::split $TaskData "\n"]]; ::foreach Line [::split $TaskData "\n"] { ::if {[::string first $DatabasePath $Line]>=0} { ::incr OpenCount 1; } } ::if {$rwb1_debug} { ::set Milli2 [::expr {[::clock clicks -milliseconds]-$Milli1}]; } ::if {$rwb1_debug} { ::puts "rwb1_debug,314120241103155050.3,OpenCount==$OpenCount"; } ::return $OpenCount; } } } ::proc ::qw::fileutil::program_qw_reg_load {sargs} { /* { Used by registration checker. Working on subscriptions. */ } ::set rwb1_debug 0; ::set DatPath [::file join $::qw_program_folder nv2.dat program.qw_reg]; ::set Data [::qw::fileutil::file_read .path $DatPath .nocomplain 1]; ::if {$Data eq ""} { ::if {$rwb1_debug} {::puts "rwb1_debug,program_qw_reg_load,1000.0,invalid checksum on registration record.";} ::return ""; } ::if {![[::qw::system] cpp_encryption_checksum_check $Data]} { /* { The checksum failed. We can't trust anything. */ } ::if {$rwb1_debug} {::puts "rwb1_debug,program_qw_reg_load,1000.0,invalid checksum on registration record.";} ::return ""; } ::return $Data; } ::proc ::qw::fileutil::program_qw_reg_store {sargs} { Used by registration checker. Working on subscriptions. ::set DatPath [::file join $::qw_program_folder nv2.dat program.qw_reg]; ::set Data [::sargs::get $sargs .data]; ::if {$Data eq ""} { ::qw::bug 314120250303162922 "[::qw::procname] - invalid .data argument \"$Data\"."; } ::set Data [[::qw::system] cpp_encryption_checksum_set $Data]; ::set Data [::sargs::format $Data]; ::qw::fileutil::file_write .path $DatPath .data $Data; [::qw::system] cpp_registration_set $Data; ::return $Data; }