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

Last change on this file since 7156 was 7156, checked in by jkh, 16 years ago

Add another (optional) argument to dportopen so that we can defeat the cache in cases where we need to open an existing instance
but set different options for it.
Reviewed by: kvv

  • Property svn:eol-style set to native
  • Property svn:executable set to *
File size: 6.3 KB
Line 
1# et:ts=4
2# portinstall.tcl
3#
4# Copyright (c) 2002 - 2003 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 portinstall 1.0
33package require portutil 1.0
34
35set com.apple.install [target_new com.apple.install install_main]
36target_runtype ${com.apple.install} always
37target_provides ${com.apple.install} install
38target_requires ${com.apple.install} main fetch extract checksum patch configure build destroot
39target_prerun ${com.apple.install} install_start
40
41set_ui_prefix
42
43proc install_start {args} {
44    global UI_PREFIX portname portversion ports_force
45   
46    # Check to make sure this port is not already installed.  This is a
47    # general check of the portname only, so previous versions will fail
48    # as well.
49    if {[string length [registry_exists $portname]] && ![tbool ports_force]} {
50        # Also check to see if it's this version or another
51        if {[string length [registry_exists $portname $portversion]]} {
52            ui_msg "$UI_PREFIX [format [msgcat::mc "Port %s already registered as installed."] $portname]"
53        } else {
54            return -code error [format [msgcat::mc "Another version of Port %s is already registered as installed.  Please uninstall the port first."] $portname]
55        }
56    } else {
57        ui_msg "$UI_PREFIX [format [msgcat::mc "Installing %s"] ${portname}]"
58    }
59}
60
61proc install_element {src_element dst_element} {
62    # don't recursively copy directories
63    if {[file isdirectory $src_element] && [file type $src_element] != "link"} {
64        file mkdir $dst_element
65    } else {
66        file copy -force $src_element $dst_element
67    }
68   
69    # if the file is a symlink, do not try to set file attributes
70    # if the destination file is an existing directory,
71    # do not overwrite its file attributes
72    if {[file type $src_element] != "link" || [file isdirectory $dst_element]} {
73        set attributes [file attributes $src_element]   
74        for {set i 0} {$i < [llength $attributes]} {incr i} {
75            set opt [lindex $attributes $i]
76            incr i
77            set arg [lindex $attributes $i]
78            file attributes $dst_element $opt $arg
79            # set mtime on installed element
80            exec touch -r $src_element $dst_element
81        }
82    }
83}
84
85proc directory_dig {rootdir workdir {cwd ""}} {
86    global installPlist
87    set pwd [pwd]
88    if {[catch {cd $workdir} err]} {
89        puts $err
90        return
91    }
92   
93    foreach name [readdir .] {
94        if {[string match $name "."] || [string match $name ".."]} {
95            continue
96        }
97        set element [file join $cwd $name]
98       
99        # XXX jpm's cross-platform code to find file separator
100        # replace with [file seperator] with tcl 8.4
101        if {![info exists root]} {
102            if {[string match [file tail "/monkey"] "monkey"]} {
103                set root "/"
104            } elseif {[string match [file tail ":monkey"] "monkey"]} {
105                set root ":" 
106            } else {
107                set root "\\"           
108            }
109        }
110       
111        set dst_element [file join $root $element]
112        set src_element [file join $rootdir $element]
113        # overwrites files but not directories
114        if {![file exists $dst_element] || ![file isdirectory $dst_element]} {
115            ui_debug "installing file: $dst_element"
116            install_element $src_element $dst_element
117            lappend installPlist $dst_element
118        }
119        if {[file isdirectory $name] && [file type $name] != "link"} {
120            directory_dig $rootdir $name [file join $cwd $name]
121        }
122    }
123    cd $pwd
124}
125
126proc install_main {args} {
127    global portname portversion portpath categories description long_description homepage depends_run installPlist package-install uninstall workdir worksrcdir prefix UI_PREFIX destroot
128   
129    # Install ${destroot} contents into /
130    directory_dig ${destroot} ${destroot}
131   
132    # Package installed successfully, so now we must register it
133    set rhandle [registry_new $portname $portversion]
134   
135    registry_store $rhandle [list prefix $prefix]
136    registry_store $rhandle [list categories $categories]
137    if {[info exists description]} {
138        registry_store $rhandle [concat description $description]
139    }
140    if {[info exists long_description]} {
141        registry_store $rhandle [concat long_description ${long_description}]
142    }
143    if {[info exists homepage]} {
144        registry_store $rhandle [concat homepage ${homepage}]
145    }
146    if {[info exists depends_run]} {
147        registry_store $rhandle [list run_depends $depends_run]
148    }
149    if {[info exists package-install]} {
150        registry_store $rhandle [concat package-install ${package-install}]
151    }
152    if {[info exists installPlist]} {
153        registry_store $rhandle [list contents [fileinfo_for_index $installPlist]]
154    }
155    if {[info proc pkg_uninstall] == "pkg_uninstall"} {
156        registry_store $rhandle [list uninstall [proc_disasm pkg_uninstall]]
157    }
158    registry_close $rhandle
159    return 0
160}
161
162proc proc_disasm {pname} {
163    set p "proc "
164    append p $pname " {"
165    set space ""
166    foreach arg [info args $pname] {
167        if {[info default $pname $arg value]} {
168            append p "$space{" [list $arg $value] "}"
169        } else {
170            append p $space $arg
171        }
172        set space " "
173    }
174    append p "} {" [info body $pname] "}"
175    return $p
176}
Note: See TracBrowser for help on using the repository browser.