TKE  3.6
Advanced code editor for programmers
files Namespace Reference

Functions

 get_info from from_type args
 
 set_info from from_type args
 
 get_file_num
 
 get_indices field ?pattern?
 
 get_tabs ?pattern?
 
 exists index
 
 is_opened fname remote
 
 num_opened fname remote
 
 get_index fname remote args
 
 modtime index
 
 normalize host fname
 
 check_file index
 
 add fname tab args
 
 remove tab
 
 gzip fname
 
 gunzip fname
 
 get_file tab pcontents
 
 set_file tab contents
 
 save_new_file save_as index
 
 get_eol_translation fname
 
 move_folder fname remote dir
 
 rename_folder old_name new_name remote
 
 delete_folder dir remote
 
 move_file fname remote dir
 
 rename_file old_name new_name remote
 
 duplicate_file fname remote
 
 delete_file fname remote
 
 move_to_trash fname isdir
 
 get_unique_path dpath fname
 
 close_tabs fname isdir
 

Function Documentation

§ add()

files::add   fname tab args  

Definition at line 311 of file files.tcl.

311  proc add {fname tab args} {
312 
313  variable files
314  variable fields
315 
316  array set opts [list \
317  -save_cmd "" \
318  -lock 0 \
319  -readonly 0 \
320  -sidebar 0 \
321  -buffer 0 \
322  -gutters [list] \
323  -diff 0 \
324  -tags [list] \
325  -loaded 0 \
326  -eol "" \
327  -remember 0 \
328  -remote "" \
329  -xview 0 \
330  -yview 0 \
331  -cursor 1.0 \
332  -encode [encoding system]]
333  array set opts $args
334 
335  set file_info [lrepeat [array size fields] ""]
336 
337  lset file_info $fields(fname) $fname
338  lset file_info $fields(mtime) ""
339  lset file_info $fields(save_cmd) $opts(-save_cmd)
340  lset file_info $fields(tab) $tab
341  lset file_info $fields(lock) $opts(-lock)
342  lset file_info $fields(readonly) [expr $opts(-readonly) || $opts(-diff)]
343  lset file_info $fields(sidebar) $opts(-sidebar)
344  lset file_info $fields(buffer) $opts(-buffer)
345  lset file_info $fields(modified) 0
346  lset file_info $fields(gutters) $opts(-gutters)
347  lset file_info $fields(diff) $opts(-diff)
348  lset file_info $fields(tags) $opts(-tags)
349  lset file_info $fields(loaded) $opts(-loaded)
350  lset file_info $fields(remember) $opts(-remember)
351  lset file_info $fields(remote) $opts(-remote)
352  lset file_info $fields(xview) $opts(-xview)
353  lset file_info $fields(yview) $opts(-yview)
354  lset file_info $fields(cursor) $opts(-cursor)
355  lset file_info $fields(encode) $opts(-encode)
356 
357  if {($opts(-remote) eq "") && !$opts(-buffer) && [file exists $fname]} {
358  lset file_info $fields(eol) [get_eol_translation $fname]
359  } else {
360  lset file_info $fields(eol) [get_eol_translation ""]
361  }
362 
363  # Add the file information to the files list
364  lappend files $file_info
365 
366  }

§ check_file()

files::check_file   index  

Definition at line 273 of file files.tcl.

273  proc check_file {index} {
274 
275  variable files
276  variable fields
277 
278  # Get the file information
279  get_info $index fileindex tab fname mtime modified
280 
281  if {$fname ne ""} {
282  if {[exists $index]} {
283  set file_mtime [modtime $index]
284  if {$mtime != $file_mtime} {
285  if {$modified} {
286  set answer [tk_messageBox -parent . -icon question -message [msgcat::mc "Reload file?"] \
287  -detail $fname -type yesno -default yes]
288  if {$answer eq "yes"} {
289  gui::update_file $index
290  }
291  } else {
292  gui::update_file $index
293  }
294  lset files $index $fields(mtime) $file_mtime
295  }
296  } elseif {$mtime ne ""} {
297  set answer [tk_messageBox -parent . -icon question -message [msgcat::mc "Delete tab?"] \
298  -detail $fname -type yesno -default yes]
299  if {$answer eq "yes"} {
300  gui::close_tab $tab -check 0
301  } else {
302  lset files $index $fields(mtime) ""
303  }
304  }
305  }
306 
307  }

§ close_tabs()

files::close_tabs   fname isdir  

Definition at line 858 of file files.tcl.

858  proc close_tabs {fname isdir} {
859 
860  # Close all of the deleted files from the UI
861  if {$isdir} {
862  gui::close_dir_files [list $fname]
863  } else {
864  gui::close_files [list $fname]
865  }
866 
867  }

§ delete_file()

files::delete_file   fname remote  

Definition at line 720 of file files.tcl.

720  proc delete_file {fname remote} {
721 
722  # Allow any plugins to handle the deletion
724 
725  if {$remote eq ""} {
726  if {[catch { file delete -force $fname} rc]} {
727  return -code error $rc
728  }
729  } else {
730  if {![remote::remove_files $remote [list $fname]]} {
731  return -code error ""
732  }
733  }
734 
735  # Close the tab associated with this filename
736  catch { gui::close_files [list $fname]}
737 
738  }

§ delete_folder()

files::delete_folder   dir remote  

Definition at line 570 of file files.tcl.

570  proc delete_folder {dir remote} {
571 
572  # Allow any plugins to handle the rename
574 
575  if {$remote eq ""} {
576  if {[catch { file delete -force -- $dir} rc]} {
577  return -code error $rc
578  }
579  } else {
580  if {![remote::remove_directories $remote [list $dir] -force 1]} {
581  return -code error ""
582  }
583  }
584 
585  # Close any opened files within one of the deleted directories
586  gui::close_dir_files [list $dir]
587 
588  }

§ duplicate_file()

files::duplicate_file   fname remote  

Definition at line 690 of file files.tcl.

690  proc duplicate_file {fname remote} {
691 
692  # Create the default name of the duplicate file
693  set dup_fname "[file rootname $fname] Copy[file extension $fname]"
694  set num 1
695  if {$remote eq ""} {
696  while {[file exists $dup_fname]} {
697  set dup_fname "[file rootname $fname] Copy [incr num][file extension $fname]"
698  }
699  if {[catch { file copy $fname $dup_fname} rc]} {
700  return -code error $rc
701  }
702  } else {
703  while {[remote::file_exists $remote $dup_fname]} {
704  set dup_fname "[file rootname $fname] Copy [incr num][file extension $fname]"
705  }
706  if {![remote::duplicate_file $remote $fname $dup_fname]} {
707  return -code error ""
708  }
709  }
710 
711  # Allow any plugins to handle the rename
712  plugins::handle_on_duplicate $fname $dup_fname
713 
714  return $dup_fname
715 
716  }

§ exists()

files::exists   index  

Definition at line 168 of file files.tcl.

168  proc exists {index} {
169 
170  get_info $index fileindex fname remote
171 
172  if {$remote eq ""} {
173  return [file exists $fname]
174  } else {
175  return [remote::file_exists $remote $fname]
176  }
177 
178  }

§ get_eol_translation()

files::get_eol_translation   fname  

Definition at line 505 of file files.tcl.

505  proc get_eol_translation {fname} {
506 
507  set type [expr {($fname eq "") ? "sys" : [preferences::get Editor/EndOfLineTranslation]}]
508 
509  switch $type {
510  auto { return [utils::get_eol_char $fname]}
511  sys { return [expr {($::tcl_platform(platform) eq "windows") ? "crlf" : "lf"}]}
512  default { return $type}
513  }
514 
515  }

§ get_file()

files::get_file   tab pcontents  

Definition at line 409 of file files.tcl.

409  proc get_file {tab pcontents} {
410 
411  variable files
412  variable fields
413 
414  get_info $tab tab fileindex fname diff remote encode
415 
416  # Set the loaded indicator
417  lset files $fileindex $fields(loaded) 1
418 
419  upvar $pcontents contents
420 
421  # Get the file contents
422  if {$remote ne ""} {
423  remote::get_file $remote $fname $encode contents modtime
424  lset files $fileindex $fields(mtime) $modtime
425  } elseif {![catch { open $fname r} rc]} {
426  fconfigure $rc -encoding $encode
427  set contents [string range [read $rc] 0 end-1]
428  close $rc
429  lset files $fileindex $fields(mtime) [file mtime $fname]
430  } else {
431  return 0
432  }
433 
434  return 1
435 
436  }

§ get_file_num()

files::get_file_num

Definition at line 127 of file files.tcl.

127  proc get_file_num {} {
128 
129  variable files
130 
131  return [llength $files]
132 
133  }

§ get_index()

files::get_index   fname remote args  

Definition at line 207 of file files.tcl.

207  proc get_index {fname remote args} {
208 
209  variable files
210  variable fields
211 
212  array set opts {
213  -diff 0
214  -buffer 0
215  }
216  array set opts $args
217 
218  foreach index [lsearch -all -index $fields(fname) $files $fname] {
219  if {([lindex $files $index $fields(remote)] eq $remote) && \
220  ([lindex $files $index $fields(diff)] eq $opts(-diff)) && \
221  ([lindex $files $index $fields(buffer)] eq $opts(-buffer))} {
222  return $index
223  }
224  }
225 
226  return -1
227 
228  }

§ get_indices()

files::get_indices   field ?pattern?  

Definition at line 137 of file files.tcl.

137  proc get_indices {field {pattern *}} {
138 
139  variable files
140  variable fields
141 
142  if {![info exists fields($field)]} {
143  return -code error "Unknown file field ($field)"
144  }
145 
146  return [lsearch -all -index $fields($field) $files $pattern]
147 
148  }

§ get_info()

files::get_info   from from_type args  

Definition at line 59 of file files.tcl.

59  proc get_info {from from_type args} {
60 
61  variable files
62  variable fields
63 
64  switch $from_type {
65  tab {
66  set index [lsearch -index $fields(tab) $files $from]
67  }
68  fileindex {
69  set index $from
70  }
71  }
72 
73  # Verify that we found a matching file
74  if {$index == -1} {
75  return -code error "files::get_info, Unable to find file with attribute ($from_type) and value ($from)"
76  }
77 
78  set i 0
79  foreach to_type $args {
80  upvar $to_type type$i
81  if {$to_type eq "fileindex"} {
82  set retval [set type$i $index]
83  } elseif {[info exists fields($to_type)]} {
84  set retval [set type$i [lindex $files $index $fields($to_type)]]
85  } else {
86  return -code error "files::get_info, Unsupported to_type ($to_type)"
87  }
88  incr i
89  }
90 
91  return $retval
92 
93  }

§ get_tabs()

files::get_tabs   ?pattern?  

Definition at line 152 of file files.tcl.

152  proc get_tabs {{pattern *}} {
153 
154  variable files
155  variable fields
156 
157  set tabs [list]
158  foreach t [lsearch -all -index $fields(tab) -inline $files $pattern] {
159  lappend tabs [lindex $t $fields(tab)]
160  }
161 
162  return $tabs
163 
164  }

§ get_unique_path()

files::get_unique_path   dpath fname  

Definition at line 844 of file files.tcl.

844  proc get_unique_path {dpath fname} {
845 
846  set path [file join $dpath $fname]
847  set index 0
848  while {[file exists $path]} {
849  set path [file join $dpath "$fname ([incr index])"]
850  }
851 
852  return [file normalize $path]
853 
854  }

§ gunzip()

files::gunzip   fname  

Definition at line 399 of file files.tcl.

399  proc gunzip {fname} {
400 
401  # TBD
402 
403  }

§ gzip()

files::gzip   fname  

Definition at line 385 of file files.tcl.

385  proc gzip {fname} {
386 
387  set fin [open $file rb]
388  set header [dict create filename $file time [file mtime $file] comment "Created by Tclinfo patchlevel"]
389  set fout [open $file.gz wb]
390  zlib push gzip $fout -header $header
391  fcopy $fin $fout
392  close $fin
393  close $fout
394 
395  }

§ is_opened()

files::is_opened   fname remote  

Definition at line 182 of file files.tcl.

182  proc is_opened {fname remote} {
183 
184  return [expr [get_index $fname $remote] != -1]
185 
186  }

§ modtime()

files::modtime   index  

Definition at line 233 of file files.tcl.

233  proc modtime {index} {
234 
235  get_info $index fileindex fname remote
236 
237  if {$remote eq ""} {
238  file stat $fname stat
239  return $stat(mtime)
240  } else {
241  return [remote::get_mtime $remote $fname]
242  }
243 
244  }

§ move_file()

files::move_file   fname remote dir  

Definition at line 592 of file files.tcl.

592  proc move_file {fname remote dir} {
593 
594  variable files
595  variable fields
596 
597  # Create the new name
598  set new_name [file join $dir [file tail $fname]]
599 
600  # Handle the move like a rename
601  plugins::handle_on_rename $fname $new_name
602 
603  # Perform the move
604  if {$remote eq ""} {
605  if {[catch { file rename -force -- $fname $new_name} rc]} {
606  return -code error $rc
607  }
608  } else {
609  if {![remote::rename_file $remote $fname $new_name]} {
610  return -code error ""
611  }
612  }
613 
614  # Find the matching file in the files list and change its filename to the new name
615  if {[set index [get_index $fname $remote]] != -1} {
616 
617  # Update the stored name to the new name and modification time
618  lset files $index $fields(fname) $new_name
619  lset files $index $fields(mtime) [modtime $index]
620 
621  # Get some information about the current file
622  gui::get_info $index fileindex tab
623 
624  # Update the tab text
625  gui::update_tab $tab
626 
627  }
628 
629  return $new_name
630 
631  }

§ move_folder()

files::move_folder   fname remote dir  

Definition at line 519 of file files.tcl.

519  proc move_folder {fname remote dir} {
520 
521  return [rename_folder $fname [file join $dir [file tail $fname]] $remote]
522 
523  }

§ move_to_trash()

files::move_to_trash   fname isdir  

Definition at line 743 of file files.tcl.

743  proc move_to_trash {fname isdir} {
744 
745  # Allow any plugins to handle the deletion
747 
748  # Move the original directory to the trash
749  switch -glob $::tcl_platform(os) {
750 
751  Darwin {
752  set cmd "tell app \"Finder\" to move the POSIX file \"$fname\" to trash"
753  if {[catch { exec -ignorestderr osascript -e $cmd} rc]} {
754  return -code error $rc
755  }
756  close_tabs $fname $isdir
757  return
758  }
759 
760  Linux* {
761  if {![catch { exec -ignorestderr which gio 2>@1}]} {
762  if {[catch { exec -ignorestderr gio trash $fname} rc]} {
763  return -code error $rc
764  }
765  close_tabs $fname $isdir
766  return
767  } elseif {![catch { exec -ignorestderr which gvfs-trash 2>@1}]} {
768  if {[catch { exec -ignorestderr gvfs-trash $fname} rc]} {
769  return -code error $rc
770  }
771  close_tabs $fname $isdir
772  return
773  } elseif {![catch { exec -ignorestderr which kioclient 2>@1}]} {
774  if {[catch { exec -ignorestderr kioclient move $fname trash:/} rc]} {
775  return -code error $rc
776  }
777  close_tabs $fname $isdir
778  return
779  } elseif {[file exists [set trash [file join ~ .local share Trash]]]} {
780  if {[info exists ::env(XDG_DATA_HOME)] && ($::env(XDG_DATA_HOME) ne "") && [file exists $::env(XDG_DATA_HOME)]} {
781  set trash $::env(XDG_DATA_HOME)
782  }
783  set trash_path [get_unique_path [file join $trash files] [file tail $fname]]
784  if {![catch { open [file join $trash info [file tail $trash_path].trashinfo] w} rc]} {
785  puts $rc "\[Trash Info\]"
786  puts $rc "Path=$fname"
787  puts $rc "DeletionDate=[clock format [clock seconds] -format {%Y-%m-%dT%T}]"
788  close $rc
789  } else {
790  return -code error $rc
791  }
792  } elseif {[file exists [set trash [file join ~ .Trash]]]} {
793  set trash_path [get_unique_path [file join $trash files] [file tail $fname]]
794  } else {
795  return -code error [msgcat::mc "Unable to determine how to move to trash"]
796  }
797  }
798 
799  *Win* {
800  set binit [file join $::tke_dir Win binit binit.exe]
801  if {[namespace exists ::freewrap] && [zvfs::exists $binit]} {
802  if {[catch { exec -ignorestderr [freewrap::unpack $binit] [file normalize $fname]} rc]} {
803  return -code error $rc
804  }
805  close_tabs $fname $isdir
806  return
807  } elseif {[file exists $binit]} {
808  if {[catch { exec -ignorestderr $binit [file normalize $fname]} rc]} {
809  return -code error $rc
810  }
811  close_tabs $fname $isdir
812  return
813  } elseif {[file exists [file join C: RECYCLER]]} {
814  set trash_path [file join C: RECYCLER]
815  } elseif {[file exists [file join C: {$Recycle.bin}]]} {
816  set trash_path [file join C: {$Recycle.bin}]
817  } else {
818  return -code error [msgcat::mc "Unable to determine how to move to trash"]
819  }
820  }
821 
822  default {
823  return -code error [msgcat::mc "Unable to determine platform"]
824  }
825 
826  }
827 
828  # Finally, move the file/directory to the trash
829  if {[catch { file rename -force $fname $trash_path} rc]} {
830  return -code error $rc
831  }
832 
833  # Close the opened tabs
834  close_tabs $fname $isdir
835 
836  }

§ normalize()

files::normalize   host fname  

Definition at line 249 of file files.tcl.

249  proc normalize {host fname} {
250 
251  # Perform a normalization of the file
252  set fname [file normalize $fname]
253 
254  # If the host does not match our host, handle the NFS mount normalization
255  if {$host ne [info hostname]} {
256  array set nfs_mounts [preferences::get NFSMounts]
257  if {[info exists nfs_mounts($host)]} {
258  lassign $nfs_mounts($host) mount_dir shortcut
259  set shortcut_len [string length $shortcut]
260  if {[string equal -length $shortcut_len $shortcut $fname]} {
261  set fname [string replace $fname 0 [expr $shortcut_len - 1] $mount_dir]
262  }
263  }
264  }
265 
266  return $fname
267 
268  }

§ num_opened()

files::num_opened   fname remote  

Definition at line 190 of file files.tcl.

190  proc num_opened {fname remote} {
191 
192  variable files
193  variable fields
194 
195  set count 0
196 
197  foreach index [lsearch -all -index $fields(fname) $files $fname*] {
198  incr count [expr {[lindex $files $index $fields(remote)] eq $remote}]
199  }
200 
201  return $count
202 
203  }

§ remove()

files::remove   tab  

Definition at line 371 of file files.tcl.

371  proc remove {tab} {
372 
373  variable files
374  variable fields
375 
376  # Get the file index
377  if {[get_info $tab tab fileindex] != -1} {
378  set files [lreplace $files $fileindex $fileindex]
379  }
380 
381  }

§ rename_file()

files::rename_file   old_name new_name remote  

Definition at line 635 of file files.tcl.

635  proc rename_file {old_name new_name remote} {
636 
637  variable files
638  variable fields
639 
640  if {$remote eq ""} {
641 
642  # Normalize the filename
643  set new_name [file normalize $new_name]
644 
645  # Allow any plugins to handle the rename
646  plugins::handle_on_rename $old_name $new_name
647 
648  # Perform the rename operation
649  if {[catch { file rename -force -- $old_name $new_name} rc]} {
650  return -code error $rc
651  }
652 
653  } else {
654 
655  # Allow any plugins to handle the rename
656  plugins::handle_on_rename $old_name $new_name
657 
658  if {![remote::rename_file $remote $old_name $new_name]} {
659  return -code error ""
660  }
661 
662  }
663 
664  # Find the matching file in the files list and change its filename to the new name
665  if {[set index [get_index $old_name $remote]] != -1} {
666 
667  # Update the stored name to the new name and modification time
668  lset files $index $fields(fname) $new_name
669  lset files $index $fields(mtime) [modtime $index]
670 
671  # Get some information about the current file
672  gui::get_info $index fileindex tab txt lang
673 
674  # Reset the syntax highlighter to match the new name
675  if {[set new_lang [syntax::get_default_language $new_name]] ne $lang} {
676  syntax::set_language $txt $new_lang
677  }
678 
679  # Update the tab text
680  gui::update_tab $tab
681 
682  }
683 
684  return $new_name
685 
686  }

§ rename_folder()

files::rename_folder   old_name new_name remote  

Definition at line 527 of file files.tcl.

527  proc rename_folder {old_name new_name remote} {
528 
529  variable files
530  variable fields
531 
532  if {$remote eq ""} {
533 
534  # Normalize the filename
535  set new_name [file normalize $new_name]
536 
537  # Allow any plugins to handle the rename
538  plugins::handle_on_rename $old_name $new_name
539 
540  if {[catch { file rename -force -- $old_name $new_name} rc]} {
541  return -code error $rc
542  }
543 
544  } else {
545 
546  # Allow any plugins to handle the rename
547  plugins::handle_on_rename $old_name $new_name
548 
549  if {![remote::rename_file $remote $old_name $new_name]} {
550  return -code error ""
551  }
552 
553  }
554 
555  # If this is a displayed file, update the file information
556  foreach index [lsearch -all -index $fields(fname) $files $old_name*] {
557  set old_fname [lindex $files $index $fields(fname)]
558  lset files $index $fields(fname) "$new_name[string range $old_fname [string length $old_name] end]"
559  lset files $index $fields(mtime) [modtime $index]
560  gui::get_info $index fileindex tab
561  gui::update_tab $tab
562  }
563 
564  return $new_name
565 
566  }

§ save_new_file()

files::save_new_file   save_as index  

Definition at line 480 of file files.tcl.

480  proc save_new_file {save_as index} {
481 
482  variable files
483  variable fields
484 
485  # Set the buffer state to 0 and clear the save command
486  if {($save_as ne "") || ([lindex $files $index $fields(fname)] ne "Untitled")} {
487  lset files $index $fields(buffer) 0
488  lset files $index $fields(save_cmd) ""
489  lset files $index $fields(remember) 1
490  return 1
491  } elseif {[set save_as [gui::prompt_for_save]] ne ""} {
492  lset files $index $fields(buffer) 0
493  lset files $index $fields(save_cmd) ""
494  lset files $index $fields(fname) $save_as
495  lset files $index $fields(remember) 1
496  return 1
497  }
498 
499  return -code error "New file was not saved"
500 
501  }

§ set_file()

files::set_file   tab contents  

Definition at line 440 of file files.tcl.

440  proc set_file {tab contents} {
441 
442  variable files
443  variable fields
444 
445  get_info $tab tab fileindex fname remote eol encode
446 
447  if {$remote ne ""} {
448 
449  # Save the file contents to the remote file
450  if {![remote::save_file $remote $fname $encode $contents modtime]} {
451  gui::set_error_message [msgcat::mc "Unable to write remote file"] ""
452  return 0
453  }
454 
455  lset files $fileindex $fields(mtime) $modtime
456 
457  } elseif {![catch { open $fname w} rc]} {
458 
459  # Write the file contents
460  catch { fconfigure $rc -translation $eol -encoding $encode}
461  puts $rc $contents
462  close $rc
463 
464  lset files $fileindex $fields(mtime) [file mtime $fname]
465 
466  } else {
467 
468  gui::set_error_message [msgcat::mc "Unable to write file"] $rc
469  return 0
470 
471  }
472 
473  return 1
474 
475  }

§ set_info()

files::set_info   from from_type args  

Definition at line 97 of file files.tcl.

97  proc set_info {from from_type args} {
98 
99  variable files
100  variable fields
101 
102  switch $from_type {
103  tab {
104  set index [lsearch -index $fields(tab) $files $from]
105  }
106  fileindex {
107  set index $from
108  }
109  }
110 
111  # Verify that we found a matching file
112  if {$index == -1} {
113  return -code error "files::get_info, Unable to find file with attribute ($from_type) and value ($from)"
114  }
115 
116  foreach {type value} $args {
117  if {![info exists fields($type)]} {
118  return -code error "files::set_info, Unsupported to_type ($type)"
119  }
120  lset files $index $fields($type) $value
121  }
122 
123  }