source: trunk/base/src/port1.0/portinstall.tcl @ 64201

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

registry fixes

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 10.0 KB
Line 
1# et:ts=4
2# portinstall.tcl
3# $Id: portinstall.tcl 64201 2010-02-25 13:51:21Z jmr@macports.org $
4#
5# Copyright (c) 2002 - 2003 Apple Computer, Inc.
6# Copyright (c) 2004 Robert Shaw <rshaw@opendarwin.org>
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 Computer, 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 portinstall 1.0
35package require portutil 1.0
36package require registry2 2.0
37
38set org.macports.install [target_new org.macports.install portinstall::install_main]
39target_provides ${org.macports.install} install
40target_runtype ${org.macports.install} always
41if {[option portarchivemode] == "yes"} {
42    target_requires ${org.macports.install} main unarchive fetch extract checksum patch configure build destroot archive
43} else {
44    target_requires ${org.macports.install} main fetch extract checksum patch configure build destroot
45}
46target_prerun ${org.macports.install} portinstall::install_start
47
48namespace eval portinstall {
49}
50
51# define options
52options install.asroot
53
54# Set defaults
55default install.asroot no
56
57set_ui_prefix
58
59proc portinstall::install_start {args} {
60    global UI_PREFIX name version revision portvariants
61    global prefix registry_open registry.format registry.path
62    ui_msg "$UI_PREFIX [format [msgcat::mc "Installing %s @%s_%s%s"] $name $version $revision $portvariants]"
63   
64    # start gsoc08-privileges
65    if { ![file writable $prefix] } {
66        # if install location is not writable, need root privileges to install
67        elevateToRoot "install"
68    }
69    # end gsoc08-privileges
70   
71    if {${registry.format} == "receipt_sqlite" && ![info exists registry_open]} {
72        registry::open [file join ${registry.path} registry registry.db]
73        set registry_open yes
74    }
75}
76
77proc portinstall::install_element {src_element dst_element} {
78    # don't recursively copy directories
79    if {[file isdirectory $src_element] && [file type $src_element] != "link"} {
80        file mkdir $dst_element
81    } else {
82        file copy -force $src_element $dst_element
83    }
84   
85    # if the file is a symlink, do not try to set file attributes
86    if {[file type $src_element] != "link"} {
87        # tclsh on 10.6 doesn't like the combination of 0444 perm and
88        # '-creator {}' (which is returned from 'file attributes <file>'; so
89        # instead just set the attributes which are needed
90        set wantedattrs {owner group permissions}
91        set file_attr_cmd {file attributes $dst_element}
92        foreach oneattr $wantedattrs {
93            set file_attr_cmd "$file_attr_cmd -$oneattr \[file attributes \$src_element -$oneattr\]"
94        }
95        eval $file_attr_cmd
96        # set mtime on installed element
97        file mtime $dst_element [file mtime $src_element]
98    }
99}
100
101proc portinstall::directory_dig {rootdir workdir imagedir {cwd ""} {prepend 1}} {
102    global installPlist
103    set pwd [pwd]
104    if {[catch {_cd $workdir} err]} {
105        puts $err
106        return
107    }
108
109    set root [file join [file separator] $imagedir]
110    foreach name [readdir .] {
111        set element [file join $cwd $name]
112
113        set dst_element [file join $root $element]
114        set src_element [file join $rootdir $element]
115        # overwrites files but not directories
116        if {![file exists $dst_element] || ![file isdirectory $dst_element]} {
117            if {[file type $src_element] == "link"} {
118                ui_debug "installing link: $dst_element"
119            } elseif {[file isdirectory $src_element]} {
120                ui_debug "installing directory: $dst_element"
121            } else {
122                ui_debug "installing file: $dst_element"
123            }
124            install_element $src_element $dst_element
125            # only track files/links for registry, not directories
126            if {[file type $dst_element] != "directory"} {
127                if {$prepend} {
128                    lappend installPlist $dst_element
129                } else {
130                    lappend installPlist [file join [file separator] $element]
131                }
132            }
133        }
134        if {[file isdirectory $name] && [file type $name] != "link"} {
135            directory_dig $rootdir $name $imagedir [file join $cwd $name] $prepend
136        }
137    }
138    _cd $pwd
139}
140
141proc portinstall::install_main {args} {
142    global name version portpath categories description long_description \
143    homepage depends_run installPlist package-install uninstall workdir \
144    worksrcdir UI_PREFIX destroot revision maintainers ports_force \
145    portvariants default_variants targets depends_lib PortInfo epoch license \
146    registry.installtype registry.path registry.format
147
148    if {[string equal ${registry.format} "receipt_sqlite"]} {
149        # registry2.0
150        registry::write {
151
152            set regref [registry::entry create $name $version $revision $portvariants $epoch]
153           
154            # Trick to have a portable GMT-POSIX epoch-based time.
155            $regref date [expr [clock scan now -gmt true] - [clock scan "1970-1-1 00:00:00" -gmt true]]
156            if {[info exists default_variants]} {
157                $regref default_variants $default_variants
158            }
159
160            foreach deplist {depends_lib depends_run} {
161                if {[info exists $deplist]} {
162                    foreach dep [set $deplist] {
163                        set dep_portname [_get_dep_port $dep]
164                        if {$dep_portname != ""} {
165                            $regref depends $dep_portname
166                        }
167                    }
168                }
169            }
170
171            if {${registry.installtype} == "image"} {
172                $regref installtype image
173                $regref state imaged
174                set imagedir [file join ${registry.path} software ${name} ${version}_${revision}${portvariants}]
175            } else {
176                $regref installtype direct
177                $regref state installed
178                set imagedir ""
179            }
180            $regref location $imagedir
181
182            # Install the files, requesting that the list not have the image dir prepended
183            directory_dig ${destroot} ${destroot} ${imagedir} "" 0
184           
185            if {[info exists installPlist]} {
186                # register files
187                $regref map $installPlist
188            }
189           
190            # store portfile
191            set fd [open [file join ${portpath} Portfile]]
192            $regref portfile [read $fd]
193            close $fd
194        }
195    } else {
196        # Begin the registry entry
197        set regref [registry_new $name $version $revision $portvariants $epoch]
198
199        set imagedir ""
200        if { [registry_prop_retr $regref installtype] == "image" } {
201            set imagedir [registry_prop_retr $regref imagedir]
202        }
203        # Install the files
204        directory_dig ${destroot} ${destroot} ${imagedir}
205
206        registry_prop_store $regref categories $categories
207
208        if {[info exists description]} {
209            registry_prop_store $regref description [string map {\n \\n} ${description}]
210        }
211        if {[info exists long_description]} {
212            registry_prop_store $regref long_description [string map {\n \\n} ${long_description}]
213        }
214        if {[info exists license]} {
215            registry_prop_store $regref license ${license}
216        }
217        if {[info exists homepage]} {
218            registry_prop_store $regref homepage ${homepage}
219        }
220        if {[info exists maintainers]} {
221            registry_prop_store $regref maintainers ${maintainers}
222        }
223        if {[info exists depends_run]} {
224            registry_prop_store $regref depends_run $depends_run
225            registry_register_deps $depends_run $name
226        }
227        if {[info exists depends_lib]} {
228            registry_prop_store $regref depends_lib $depends_lib
229            registry_register_deps $depends_lib $name
230        }
231        if {[info exists installPlist]} {
232            registry_prop_store $regref contents [registry_fileinfo_for_index $installPlist]
233            if { [registry_prop_retr $regref installtype] != "image" } {
234                registry_bulk_register_files [registry_fileinfo_for_index $installPlist] $name
235            }
236        }
237        if {[info exists package-install]} {
238            registry_prop_store $regref package-install ${package-install}
239        }
240        if {[info proc pkg_uninstall] == "pkg_uninstall"} {
241            registry_prop_store $regref uninstall [proc_disasm pkg_uninstall]
242        }
243
244        registry_write $regref
245    }
246
247    return 0
248}
249
250proc portinstall::proc_disasm {pname} {
251    set p "proc "
252    append p $pname " \{"
253    set space ""
254    foreach arg [info args $pname] {
255        if {[info default $pname $arg value]} {
256            append p "$space{" [list $arg $value] "}"
257        } else {
258            append p $space $arg
259        }
260        set space " "
261    }
262    append p "\} \{" [info body $pname] "\}"
263    return $p
264}
Note: See TracBrowser for help on using the repository browser.