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

Last change on this file since 1015 was 1015, checked in by kevin, 18 years ago

Remove 'register' proc.
Now targets have a handle to the target object directly. Alleviates need for
unique names, and simplifies pre-${target}/post-${target} implementation.
Will allow for future enhancement to options and variants.

  • Property svn:eol-style set to native
  • Property svn:executable set to *
File size: 7.4 KB
Line 
1# ex: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
40# define options
41options contents long_description description registry.nochecksum registry.path registry.nobzip registry.contents_recurse
42
43# Export options via PortInfo
44options_export description long_description
45
46default registry.path {[file join ${portdbpath} receipts]}
47
48set UI_PREFIX "---> "
49
50# For now, just write stuff to a file for debugging.
51
52proc registry_new {portname {portversion 1.0}} {
53    global _registry_name registry.path
54
55    file mkdir ${registry.path}
56    set _registry_name [file join ${registry.path} $portname-$portversion]
57    system "rm -f ${_registry_name}.tmp"
58    set rhandle [open ${_registry_name}.tmp w 0644]
59    puts $rhandle "\# Format: var value ... {contents {filename uid gid mode size {md5}} ... }"
60    return $rhandle
61}
62
63proc registry_exists {portname {portversion 0}} {
64    global registry.path
65
66    # regex match case
67    if {$portversion == 0} {
68        set x [glob -nocomplain [file join ${registry.path} ${portname}-*]]
69        if [string length $x] {
70            set matchfile [lindex $x 0]
71        } else {
72            set matchfile ""
73        }
74    } else {
75        set matchfile [file join ${registry.path} ${portname}-${portversion}]
76    }
77
78    # Might as well bail out early if no file to match
79    if ![string length $matchfile] {
80        return ""
81    }
82
83    if [file exists $matchfile] {
84        return $matchfile
85    }
86    if [file exists ${matchfile}.bz2] {
87        return ${matchfile}.bz2
88    }
89    return ""
90}
91
92proc registry_store {rhandle data} {
93    puts $rhandle $data
94}
95
96proc registry_fetch {rhandle} {
97    return -1
98}
99
100proc registry_traverse {func} {
101    return -1
102}
103
104proc registry_close {rhandle} {
105    global _registry_name
106    global registry.nobzip
107
108    close $rhandle
109    system "mv ${_registry_name}.tmp ${_registry_name}"
110    if {[file exists ${_registry_name}] && [file exists /usr/bin/bzip2] && ![info exists registry.nobzip]} {
111        system "/usr/bin/bzip2 -f ${_registry_name}"
112    }
113}
114
115proc registry_delete {portname {portversion 1.0}} {
116    global registry.path
117
118    # Try both versions, just to be sure.
119    exec rm -f [file join ${registry.path} ${portname}-${portversion}]
120    exec rm -f [file join ${registry.path} ${portname}-${portversion}].bz2
121}
122
123proc fileinfo_for_file {fname} {
124    global registry.nochecksum
125
126    if ![catch {file stat $fname statvar}] {
127        if {![tbool registry.nochecksum] && [file isfile $fname]} {
128            set md5regex "^(MD5)\[ \]\\((.+)\\)\[ \]=\[ \](\[A-Za-z0-9\]+)\n$"
129            set pipe [open "|md5 \"$fname\"" r]
130            set line [read $pipe]
131            if {[regexp $md5regex $line match type filename sum] == 1} {
132                close $pipe
133                set line [string trimright $line "\n"]
134                return [list $fname $statvar(uid) $statvar(gid) $statvar(mode) $statvar(size) $line]
135            }
136            close $pipe
137        } else {
138            return  [list $fname $statvar(uid) $statvar(gid) $statvar(mode) $statvar(size) "MD5 ($fname) NONE"]
139        }
140    }
141    return {}
142}
143
144proc fileinfo_for_entry {rval dir entry} {
145    global registry.contents_recurse UI_PREFIX
146
147    upvar $rval myrval
148    set path [file join $dir $entry]
149    if {[file isdirectory $path] && [tbool registry.contents_recurse]} {
150        foreach name [readdir $path] {
151            if {[string match $name .] || [string match $name ..]} {
152                continue
153            }
154            set subpath [file join $path $name]
155            if [file isdirectory $subpath] {
156                fileinfo_for_entry myrval $subpath ""
157            } elseif [file readable $subpath] {
158                lappend myrval [fileinfo_for_file $subpath]
159            }
160        }
161    }
162    lappend myrval [fileinfo_for_file $path]
163    return $myrval
164}
165
166proc fileinfo_for_index {flist} {
167    global prefix registry.contents_recurse UI_PREFIX
168
169    set rval {}
170    foreach file $flist {
171        if [string match /* $file] {
172            set fname $file
173            set dir /
174        } else {
175            set fname [file join $prefix $file]
176            set dir $prefix
177        }
178        if {[file isdirectory $fname] && [tbool registry.contents_recurse]} {
179            ui_msg "$UI_PREFIX Warning: Registry adding contents of directory $fname"
180        }
181        fileinfo_for_entry rval $dir $file
182    }
183    return $rval
184}
185
186proc proc_disasm {pname} {
187    set p "proc "
188    append p $pname " {"
189    set space ""
190    foreach arg [info args $pname] {
191        if [info default $pname $arg value] {
192            append p "$space{" [list $arg $value] "}"
193        } else {
194            append p $space $arg
195        }
196        set space " "
197    }
198    append p "} {" [info body $pname] "}"
199    return $p
200}
201
202proc registry_main {args} {
203    global portname portversion portpath categories description long_description depends_run contents package-install uninstall workdir worksrcdir prefix UI_PREFIX
204
205    # Package installed successfully, so now we must register it
206    set rhandle [registry_new $portname $portversion]
207    ui_msg "$UI_PREFIX Adding $portname to registry, this may take a moment..."
208
209    registry_store $rhandle [list prefix $prefix]
210    registry_store $rhandle [list categories $categories]
211    if [info exists description] {
212        registry_store $rhandle [concat description $description]
213    }
214    if [info exists long_description] {
215        registry_store $rhandle [concat long_description ${long_description}]
216    }
217    if [info exists depends_run] {
218        registry_store $rhandle [list run_depends $depends_run]
219    }
220    if [info exists package-install] {
221        registry_store $rhandle [concat package-install ${package-install}]
222    }
223    if [info exists contents] {
224        # If it's a list, try and split it up.
225        if {[llength $contents] == 1} {
226            set x [list contents [eval fileinfo_for_index $contents]]
227        } else {
228            set x [list contents [fileinfo_for_index $contents]]
229        }
230        registry_store $rhandle $x
231    }
232    if {[info proc uninstall] == "uninstall"} {
233        registry_store $rhandle [list uninstall [proc_disasm uninstall]]
234    }
235    registry_close $rhandle
236    return 0
237}
Note: See TracBrowser for help on using the repository browser.