/usr/share/tcltk/xotcl1.6.7-store/TextFileStorage.xotcl is in xotcl 1.6.7-2.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 | package provide xotcl::store::textfile 0.84
package require xotcl::store
package require XOTcl
namespace eval ::xotcl::store::textfile {
namespace import ::xotcl::*
Class Storage=TextFile -superclass Storage -parameter {
filename
reorgCounter
reorgMaxValue
}
Storage=TextFile instproc init args {
my instvar reorgCounter reorgMaxValue searchID
::set reorgCounter 0
::set reorgMaxValue 1000
::set searchID ""
next
}
Storage=TextFile instproc reorganizeDB {} {
my instvar noreorg reorgCounter reorgMaxValue filename keys
::set reorgCounter -1
#puts "***reorganizeDB"
if {[::info exists filename]} {
::set noreorg 1
::array set bkeys [::array get keys]
::array set keys {}
# parray bkeys
::set bak $filename.orig
file rename -force $filename $bak
foreach k [::array names bkeys] {
::set bf [::open $bak r]
seek $bf [lindex $bkeys($k) 0]
::set c [read $bf [lindex $bkeys($k) 1]]
::close $bf
#puts "***STORING $k [lindex $c 1]"
my set $k [lindex $c 1]
}
file delete -force $bak
::unset noreorg
}
}
Storage=TextFile instproc open fn {
my instvar keys filename
::array set keys {}
::set position 0
::set filename $fn
if {[file exists $filename]} {
::set f [::open $filename r]
::set c [read $f]
::close $f
foreach {k v} $c {
lappend keyList $k
}
::set f [::open $filename r]
while {1} {
set position [tell $f]
if {!([gets $f line] >= 0)} {
break
}
set k [lindex $keyList 0]
if {[string match $k* $line]} {
set lastLength [string length $line]
set keys($k) [concat $position $lastLength]
set lastKey $k
set lastPosition $position
set keyList [lreplace $keyList 0 0]
} elseif {[info exists lastKey]} {
set lastLength [expr $lastLength + [string length $line] + 1]
set keys($lastKey) [concat $lastPosition $lastLength]
}
}
::close $f
#parray keys
}
}
Storage=TextFile instproc exists key {
my instvar keys
info exists keys($key)
}
Storage=TextFile instproc set args {
my instvar keys noreorg reorgCounter reorgMaxValue filename
::set key [lindex $args 0]
::set l [llength $args]
if {$l == 1} { ;# fetch
if {[::info exists keys($key)]} {
::set f [::open $filename r]
#puts "***fetch -- $keys($key)"
seek $f [lindex $keys($key) 0]
::set c [read $f [lindex $keys($key) 1]]
::close $f
return [lindex $c 1]
} else {
error "no such variable '$key'"
}
} elseif {$l == 2} { ;# store
if {![::info exists noreorg] && [::info exists keys($key)]} {
::incr reorgCounter
}
::set f [::open $filename a+]
::set position [tell $f]
#puts "***store -- putting [::list $key [lindex $args 1]] at $position"
::set c [::list $key [lindex $args 1]]
puts $f $c
::close $f
::set keys($key) [::list $position [expr {[string length $c] + 1}]]
# parray keys
if {$reorgCounter > $reorgMaxValue} {
my reorganizeDB
}
} else { next }
}
Storage=TextFile instproc names {} {
my array names keys
}
Storage=TextFile instproc close {} {
my instvar filename keys
my reorganizeDB
::unset filename
::unset keys
}
Storage=TextFile instproc unset key {
my instvar keys
if {[::info exists keys($key)]} {
::unset keys($key)
}
my reorganizeDB
}
Storage=TextFile instproc firstkey {} {
my instvar keys searchID
if {$searchID ne ""} {
array donesearch keys $searchID
}
::set searchID [array startsearch keys]
return [array nextelement keys $searchID]
}
Storage=TextFile instproc nextkey {} {
my instvar keys searchID
if {$searchID eq ""} {
error "[self class]: firstkey was not invoked on storage search"
}
::set elt [array nextelement keys $searchID]
if {$elt eq ""} {
# if array end is reach search is terminated automatically!!
::set searchID ""
}
return $elt
}
namespace export Storage=TextFile
}
namespace import ::xotcl::store::textfile::*
|