source: branches/release_2_0/base/src/registry2.0/receipt_sqlite.tcl @ 81465

Last change on this file since 81465 was 81465, checked in by jmr@…, 9 years ago

merge r81464 from trunk:

add progress output to images_to_archives.tcl (#30347)

File size: 8.9 KB
Line 
1# receipt_sqlite.tcl
2# $Id: receipt_sqlite.tcl 81465 2011-07-31 09:42:32Z jmr@macports.org $
3#
4# Copyright (c) 2010-2011 The MacPorts Project
5# Copyright (c) 2004 Will Barton <wbb4@opendarwin.org>
6# Copyright (c) 2002 Apple Inc.
7# All rights reserved.
8#
9# Redistribution and use in source and binary forms, with or without
10# modification, are permitted provided that the following conditions
11# are met:
12# 1. Redistributions of source code must retain the above copyright
13#    notice, this list of conditions and the following disclaimer.
14# 2. Redistributions in binary form must reproduce the above copyright
15#    notice, this list of conditions and the following disclaimer in the
16#    documentation and/or other materials provided with the distribution.
17# 3. Neither the name of Apple Inc. nor the names of its contributors
18#    may be used to endorse or promote products derived from this software
19#    without specific prior written permission.
20#
21# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
22# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
23# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
24# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
25# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
26# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
27# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
28# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
29# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
30# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
31# POSSIBILITY OF SUCH DAMAGE.
32#
33
34package provide receipt_sqlite 1.0
35
36package require macports 1.0
37package require registry2 2.0
38package require registry_util 2.0
39
40##
41# registry2.0 wrapper code that matches old receipt_flat interface
42##
43namespace eval receipt_sqlite {
44
45# return list of active ports, or active version of port 'name' if specified
46proc active {name} {
47    if {$name != ""} {
48        set ports [registry::entry installed $name]
49    } else {
50        set ports [registry::entry installed]
51    }
52    set rlist [list]
53    foreach port $ports {
54        lappend rlist [list [$port name] [$port version] [$port revision] [$port variants] [string equal [$port state] "installed"] [$port epoch]]
55    }
56    return $rlist
57}
58
59##
60# Open an existing entry and return a reference.
61proc open_entry {name version revision variants epoch} {
62    return [registry::entry open $name $version $revision $variants $epoch]
63}
64
65# Check to see if an entry exists
66proc entry_exists {name version {revision 0} {variants ""}} {
67    if {![catch {set ports [registry::entry search name $name version $version revision $revision variants $variants]}] && [llength $ports] > 0} {
68        return 1
69    }
70        return 0
71}
72
73# Check to see if an entry exists
74proc entry_exists_for_name {name} {
75        if {![catch {set ports [registry::entry search name $name]}] && [llength $ports] > 0} {
76            return 1
77        }
78        return 0
79}
80
81##
82# determine if a file is registered in the file map, and if it is,
83# get its port.
84#
85# - file        the file to test
86# returns 0 if the file is not registered, the name of the port otherwise.
87#
88proc file_registered {file} {
89    set port [registry::entry owner $file]
90        if {$port != ""} {
91                return [$port name]
92        } else {
93                return 0
94        }
95}
96
97##
98# determine if a port is registered in the file map, and if it is,
99# get its installed (activated) files.
100#
101# - port        the port to test
102# returns 0 if the port is not registered, the list of its files otherwise.
103proc port_registered {name} {
104        if {![catch {set ports [registry::entry installed $name]}]
105            && [llength $ports] > 0} {
106            # should never return more than one port
107            set port [lindex $ports 0]
108                return [$port files]
109        } elseif {![catch {set ports [registry::entry imaged $name]}]
110            && [llength $ports] > 0} {
111            return ""
112        } else {
113        return 0
114    }
115}
116
117##
118# Retrieve a property from a registry entry.
119#
120# ref                   reference to the entry.
121# property              key for the property to retrieve.
122proc property_retrieve {ref property} {
123    switch $property {
124        active {
125            set ret [string equal [$ref state] "installed"]
126        }
127        default {
128            if {[catch {set ret [$ref $property]}]} {
129                # match behaviour of receipt_flat
130                set ret 0
131            }
132        }
133    }
134    return $ret
135}
136
137##
138# Store a property in a registry entry.
139#
140# ref                   reference to the entry.
141# property              key for the property to set.
142# value         value to set it to.
143proc property_store {ref property value} {
144    switch $property {
145        active {
146            if {!$value} {
147                $ref state "imaged"
148            } else {
149                $ref state "installed"
150            }
151        }
152        default {
153            $ref $property $value
154        }
155    }
156}
157
158# Return installed ports
159#
160# If version is "", return all ports of that name.
161# Otherwise, return only ports that exactly match this version.
162# What we call version here is version_revision+variants.
163# The syntax for that can be ambiguous if there's an underscore and dash in
164# version for example, so we don't attempt to split up the composite version
165# into its components, we just compare the whole thing.
166proc installed {{name ""} {version ""}} {
167        if { $name == "" && $version == "" } {
168            set ports [registry::entry imaged]
169        } elseif { $name != "" && $version == ""} {
170            set ports [registry::entry imaged $name]
171        } else {
172            set ports {}
173            set possible_ports [registry::entry imaged $name]
174            foreach p $possible_ports {
175                if {"[$p version]_[$p revision][$p variants]" == $version
176                    || [$p version] == $version} {
177                    lappend ports $p
178                }
179            }
180        }
181
182    set rlist [list]
183    foreach port $ports {
184        lappend rlist [list [$port name] [$port version] [$port revision] [$port variants] [string equal [$port state] "installed"] [$port epoch]]
185    }
186        return $rlist
187}
188
189proc close_file_map {args} {
190}
191
192proc open_dep_map {args} {
193}
194
195# List all the ports that this port depends on
196proc list_depends {name version revision variants} {
197        set rlist [list]
198        set searchcmd "registry::entry search"
199    foreach key {name version revision} {
200        if {[set $key] != ""} {
201            append searchcmd " $key [set $key]"
202        }
203    }
204    if {$variants != 0} {
205        append searchcmd " variants {$variants}"
206    }
207    if {[catch {set ports [eval $searchcmd]}]} {
208        set ports [list]
209    }
210    foreach port $ports {
211        foreach dep [$port dependencies] {
212            lappend rlist [list [$dep name] port [$port name]]
213        }
214    }
215       
216        return [lsort -unique $rlist]
217}
218
219# List all the ports that depend on this port
220proc list_dependents {name version revision variants} {
221        set rlist [list]
222        set searchcmd "registry::entry search"
223    foreach key {name version revision} {
224        if {[set $key] != ""} {
225            append searchcmd " $key [set $key]"
226        }
227    }
228    if {$variants != 0} {
229        append searchcmd " variants {$variants}"
230    }
231    if {[catch {set ports [eval $searchcmd]}]} {
232        set ports [list]
233    }
234    foreach port $ports {
235        set dependents [$port dependents]
236        foreach dependent $dependents {
237            lappend rlist [list [$port name] port [$dependent name]]
238        }
239    }
240       
241        return [lsort -unique $rlist]
242}
243
244# adds a registry entry from a list of keys and values
245proc create_entry_l {proplist} {
246    array set props $proplist
247    registry::write {
248        set regref [registry::entry create $props(name) $props(version) $props(revision) $props(variants) $props(epoch)]
249        $regref date $props(date)
250        $regref requested $props(requested)
251        $regref location $props(location)
252        $regref state $props(state)
253        $regref installtype $props(installtype)
254        if {$props(installtype) == "image"} {
255            $regref map $props(imagefiles)
256            if {$props(state) == "installed"} {
257                if {[llength $props(imagefiles)] != [llength $props(files)]} {
258                    # deal with this mess, just drop the extras...
259                    set i 0
260                    set ilist {}; set flist {}
261                    while {$i < [llength $props(imagefiles)] && $i < [llength $props(files)]} {
262                        lappend ilist [lindex $props(imagefiles) $i]
263                        lappend flist [lindex $props(files) $i]
264                        incr i
265                    }
266                    $regref activate $ilist $flist
267                } else {
268                    $regref activate $props(imagefiles) $props(files)
269                }
270            }
271        } else {
272            $regref map $props(files)
273        }
274        foreach key {negated_variants os_platform os_major archs} {
275            if {$props($key) != 0} {
276                $regref $key $props($key)
277            } else {
278                $regref $key ""
279            }
280        }
281        foreach dep_portname $props(depends) {
282            $regref depends $dep_portname
283        }
284        $regref portfile $props(portfile)
285    }
286}
287
288# End of receipt_sqlite namespace
289}
Note: See TracBrowser for help on using the repository browser.