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

Last change on this file since 3954 was 3954, checked in by fkr, 17 years ago

Bug:
Submitted by: wbb4@
Reviewed by:
Approved by:
Obtained from:

enabled uninstall to work properly when version in dports-tree is not equal
installed version.
also add's installed check, so a port is not accidently installed over an existing
version.

  • Property svn:eol-style set to native
  • Property svn:executable set to *
File size: 6.2 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
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]]} {
50                # Also check to see if it's this version or another
51                if {[string length [registry_exists $portname $portversion]]} {
52                        return -code error [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.