source: trunk/base/src/port1.0/portregistry.tcl @ 1528

Last change on this file since 1528 was 1528, checked in by jkh, 18 years ago

Permanently retire the contents { .. } hack. Sorry. It was convenient,
it looked nicer in many cases, but it was frankly more of a special-case pain
than it was worth in terms of its impact on other infrastructural routines
that expected to be able to deal with the contents procedure the same as all
the others. Better to just throw this out all at once and nuke all existing
examples of it so nobody tries to use it in the future. The support for it
has also been fundamentally removed, so it also won't work if people accidently
try to use it.

  • Property svn:eol-style set to native
  • Property svn:executable set to *
File size: 7.3 KB
Line 
1# et:ts=4
2# portregistry.tcl
3#
4# Copyright (c) 2002 Apple Computer, Inc.
5# All rights reserved.
6#
7# Redistribution and use in source and binary forms, with or without
8# modification, are permitted provided that the following conditions
9# are met:
10# 1. Redistributions of source code must retain the above copyright
11#    notice, this list of conditions and the following disclaimer.
12# 2. Redistributions in binary form must reproduce the above copyright
13#    notice, this list of conditions and the following disclaimer in the
14#    documentation and/or other materials provided with the distribution.
15# 3. Neither the name of Apple Computer, Inc. nor the names of its contributors
16#    may be used to endorse or promote products derived from this software
17#    without specific prior written permission.
18#
19# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
20# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
21# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
22# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
23# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
24# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
25# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
26# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
27# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
28# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
29# POSSIBILITY OF SUCH DAMAGE.
30#
31
32package provide portregistry 1.0
33package require portutil 1.0
34
35set com.apple.registry [target_new com.apple.registry registry_main]
36${com.apple.registry} provides registry
37${com.apple.registry} requires main fetch extract checksum patch configure build install
38${com.apple.registry} deplist depends_run depends_lib
39${com.apple.registry} set prerun registry_start
40
41# define options
42options contents long_description description registry.nochecksum registry.path registry.nobzip registry.contents_recurse
43
44# Export options via PortInfo
45options_export description long_description
46
47default registry.path {[file join ${portdbpath} receipts]}
48
49set UI_PREFIX "---> "
50
51proc registry_start {args} {
52    global UI_PREFIX portname
53
54    ui_msg "$UI_PREFIX Adding $portname to registry, this may take a moment..."
55}
56
57# For now, just write stuff to a file for debugging.
58
59proc registry_new {portname {portversion 1.0}} {
60    global _registry_name registry.path
61
62    file mkdir ${registry.path}
63    set _registry_name [file join ${registry.path} $portname-$portversion]
64    system "rm -f ${_registry_name}.tmp"
65    set rhandle [open ${_registry_name}.tmp w 0644]
66    puts $rhandle "\# Format: var value ... {contents {filename uid gid mode size {md5}} ... }"
67    return $rhandle
68}
69
70proc registry_exists {portname {portversion 0}} {
71    global registry.path
72
73    # regex match case
74    if {$portversion == 0} {
75        set x [glob -nocomplain [file join ${registry.path} ${portname}-*]]
76        if [string length $x] {
77            set matchfile [lindex $x 0]
78        } else {
79            set matchfile ""
80        }
81    } else {
82        set matchfile [file join ${registry.path} ${portname}-${portversion}]
83    }
84
85    # Might as well bail out early if no file to match
86    if ![string length $matchfile] {
87        return ""
88    }
89
90    if [file exists $matchfile] {
91        return $matchfile
92    }
93    if [file exists ${matchfile}.bz2] {
94        return ${matchfile}.bz2
95    }
96    return ""
97}
98
99proc registry_store {rhandle data} {
100    puts $rhandle $data
101}
102
103proc registry_fetch {rhandle} {
104    return -1
105}
106
107proc registry_traverse {func} {
108    return -1
109}
110
111proc registry_close {rhandle} {
112    global _registry_name
113    global registry.nobzip
114
115    close $rhandle
116    system "mv ${_registry_name}.tmp ${_registry_name}"
117    if {[file exists ${_registry_name}] && [file exists /usr/bin/bzip2] && ![info exists registry.nobzip]} {
118        system "/usr/bin/bzip2 -f ${_registry_name}"
119    }
120}
121
122proc registry_delete {portname {portversion 1.0}} {
123    global registry.path
124
125    # Try both versions, just to be sure.
126    exec rm -f [file join ${registry.path} ${portname}-${portversion}]
127    exec rm -f [file join ${registry.path} ${portname}-${portversion}].bz2
128}
129
130proc fileinfo_for_file {fname} {
131    global registry.nochecksum
132
133    if ![catch {file stat $fname statvar}] {
134        if {![tbool registry.nochecksum] && [file isfile $fname]} {
135            set md5regex "^(MD5)\[ \]\\((.+)\\)\[ \]=\[ \](\[A-Za-z0-9\]+)\n$"
136            set pipe [open "|md5 \"$fname\"" r]
137            set line [read $pipe]
138            if {[regexp $md5regex $line match type filename sum] == 1} {
139                close $pipe
140                set line [string trimright $line "\n"]
141                return [list $fname $statvar(uid) $statvar(gid) $statvar(mode) $statvar(size) $line]
142            }
143            close $pipe
144        } else {
145            return  [list $fname $statvar(uid) $statvar(gid) $statvar(mode) $statvar(size) "MD5 ($fname) NONE"]
146        }
147    }
148    return {}
149}
150
151proc fileinfo_for_entry {rval dir entry} {
152    global registry.contents_recurse UI_PREFIX
153
154    upvar $rval myrval
155    set path [file join $dir $entry]
156    if {[file isdirectory $path] && [tbool registry.contents_recurse]} {
157        foreach name [readdir $path] {
158            if {[string match $name .] || [string match $name ..]} {
159                continue
160            }
161            set subpath [file join $path $name]
162            if [file isdirectory $subpath] {
163                fileinfo_for_entry myrval $subpath ""
164            } elseif [file readable $subpath] {
165                lappend myrval [fileinfo_for_file $subpath]
166            }
167        }
168    }
169    lappend myrval [fileinfo_for_file $path]
170    return $myrval
171}
172
173proc fileinfo_for_index {flist} {
174    global prefix registry.contents_recurse UI_PREFIX
175
176    set rval {}
177    foreach file $flist {
178        if [string match /* $file] {
179            set fname $file
180            set dir /
181        } else {
182            set fname [file join $prefix $file]
183            set dir $prefix
184        }
185        if {[file isdirectory $fname] && [tbool registry.contents_recurse]} {
186            ui_msg "$UI_PREFIX Warning: Registry adding contents of directory $fname"
187        }
188        fileinfo_for_entry rval $dir $file
189    }
190    return $rval
191}
192
193proc proc_disasm {pname} {
194    set p "proc "
195    append p $pname " {"
196    set space ""
197    foreach arg [info args $pname] {
198        if [info default $pname $arg value] {
199            append p "$space{" [list $arg $value] "}"
200        } else {
201            append p $space $arg
202        }
203        set space " "
204    }
205    append p "} {" [info body $pname] "}"
206    return $p
207}
208
209proc registry_main {args} {
210    global portname portversion portpath categories description long_description depends_run contents package-install uninstall workdir worksrcdir prefix UI_PREFIX
211
212    # Package installed successfully, so now we must register it
213    set rhandle [registry_new $portname $portversion]
214
215    registry_store $rhandle [list prefix $prefix]
216    registry_store $rhandle [list categories $categories]
217    if [info exists description] {
218        registry_store $rhandle [concat description $description]
219    }
220    if [info exists long_description] {
221        registry_store $rhandle [concat long_description ${long_description}]
222    }
223    if [info exists depends_run] {
224        registry_store $rhandle [list run_depends $depends_run]
225    }
226    if [info exists package-install] {
227        registry_store $rhandle [concat package-install ${package-install}]
228    }
229    if [info exists contents] {
230        registry_store $rhandle [list contents [fileinfo_for_index $contents]]
231    }
232    if {[info proc pkg_uninstall] == "pkg_uninstall"} {
233        registry_store $rhandle [list uninstall [proc_disasm pkg_uninstall]]
234    }
235    registry_close $rhandle
236    return 0
237}
Note: See TracBrowser for help on using the repository browser.