source: trunk/base/src/darwinports1.0/darwinports.tcl @ 15657

Last change on this file since 15657 was 15657, checked in by jberry, 15 years ago

Bug: 6169
Submitted by: Brian Zhou; patch by Bryan Blackburn
Reviewed by: jberry@
Approved by: jberry@

Add RSYNC_PROXY to the list of environment variables not to wipe.

  • Property svn:eol-style set to native
File size: 53.0 KB
Line 
1# darwinports.tcl
2# $Id: darwinports.tcl,v 1.202 2005/12/31 04:48:05 jberry Exp $
3#
4# Copyright (c) 2002 Apple Computer, Inc.
5# Copyright (c) 2004 - 2005 Paul Guyot, <pguyot@kallisys.net>.
6# Copyright (c) 2004 Ole Guldberg Jensen <olegb@opendarwin.org>.
7# Copyright (c) 2004 - 2005 Robert Shaw <rshaw@opendarwin.org>
8# All rights reserved.
9#
10# Redistribution and use in source and binary forms, with or without
11# modification, are permitted provided that the following conditions
12# are met:
13# 1. Redistributions of source code must retain the above copyright
14#    notice, this list of conditions and the following disclaimer.
15# 2. Redistributions in binary form must reproduce the above copyright
16#    notice, this list of conditions and the following disclaimer in the
17#    documentation and/or other materials provided with the distribution.
18# 3. Neither the name of Apple Computer, Inc. nor the names of its contributors
19#    may be used to endorse or promote products derived from this software
20#    without specific prior written permission.
21#
22# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
23# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
24# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
25# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
26# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
27# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
28# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
29# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
30# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
31# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
32# POSSIBILITY OF SUCH DAMAGE.
33#
34package provide darwinports 1.0
35package require darwinports_dlist 1.0
36package require darwinports_index 1.0
37
38namespace eval darwinports {
39    namespace export bootstrap_options portinterp_options open_dports ui_priorities
40    variable bootstrap_options "portdbpath libpath binpath auto_path extra_env sources_conf prefix portdbformat portinstalltype portarchivemode portarchivepath portarchivetype portautoclean porttrace portverbose destroot_umask variants_conf rsync_server rsync_options rsync_dir startupitem_type xcodeversion xcodebuildcmd"
41    variable portinterp_options "portdbpath portpath portbuildpath auto_path prefix portsharepath registry.path registry.format registry.installtype portarchivemode portarchivepath portarchivetype portautoclean porttrace portverbose destroot_umask rsync_server rsync_options rsync_dir startupitem_type"
42    # deferred options are only computed when needed.
43    # they are not exported to the trace thread.
44    # they are not exported to the interpreter in system_options array.
45    variable portinterp_deferred_options "xcodeversion xcodebuildcmd"
46       
47    variable open_dports {}
48   
49    variable ui_priorities "debug info msg error warn"
50}
51
52# Provided UI instantiations
53# For standard messages, the following priorities are defined
54#     debug, info, msg, warn, error
55# Clients of the library are expected to provide ui_prefix and ui_channels with
56# the following prototypes.
57#     proc ui_prefix {priority}
58#     proc ui_channels {priority}
59# ui_prefix returns the prefix for the messages, if any.
60# ui_channels returns a list of channels to output the message to, empty for
61#     no message.
62
63proc darwinports::ui_init {priority message} {
64        # Get the list of channels.
65        set channels [ui_channels $priority]
66
67        # Simplify ui_$priority.
68        set nbchans [llength $channels]
69        if {$nbchans == 0} {
70                eval "proc ::ui_$priority {str} {}"
71        } else {
72                set prefix [ui_prefix $priority]
73
74                if {$nbchans == 1} {
75                        set chan [lindex $channels 0]
76                        eval "proc ::ui_$priority {str} \{ puts $chan \"$prefix\$str\" \}"
77                } else {
78                        eval "proc ::ui_$priority {str} \{ \n\
79                                foreach chan $channels \{ \n\
80                                        puts $chan \"$prefix\$str\" \n\
81                                \} \n\
82                        \}"
83                }
84
85                # Call ui_$priority
86                ::ui_$priority $message
87        }
88}
89
90foreach priority ${darwinports::ui_priorities} {
91    eval "proc ui_$priority {str} \{ darwinports::ui_init $priority \$str \}"
92}
93
94# Replace puts to catch errors (typically broken pipes when being piped to head)
95rename puts tcl::puts
96proc puts {args} {
97        catch "tcl::puts $args"
98}
99
100# check for a binary in the path
101# returns an error code if it can not be found
102# copied from portutil.tcl
103proc darwinports::binaryInPath {binary} {
104    global env
105    foreach dir [split $env(PATH) :] { 
106        if {[file executable [file join $dir $binary]]} {
107            return [file join $dir $binary]
108        }
109    }
110   
111    return -code error [format [msgcat::mc "Failed to locate '%s' in path: '%s'"] $binary $env(PATH)];
112}
113
114# deferred option processing
115proc darwinports::getoption {name} {
116        global darwinports::$name
117        return [expr $$name]
118}
119
120# deferred and on-need extraction of xcodeversion and xcodebuildcmd.
121proc darwinports::setxcodeinfo {name1 name2 op} {
122        global darwinports::xcodeversion
123        global darwinports::xcodebuildcmd
124       
125        trace remove variable darwinports::xcodeversion read darwinports::setxcodeinfo
126        trace remove variable darwinports::xcodebuildcmd read darwinports::setxcodeinfo
127
128        if {[catch {set xcodebuild [binaryInPath "xcodebuild"]}] == 0} {
129                if {![info exists xcodeversion]} {
130                        # Determine xcode version (<= 2.0 or 2.1)
131                        if {[catch {set xcodebuildversion [exec xcodebuild -version]}] == 0} {
132                                if {[regexp "DevToolsCore-(.*); DevToolsSupport-(.*)" $xcodebuildversion devtoolscore_v devtoolssupport_v] == 1} {
133                                        if {$devtoolscore_v >= 620.0 && $devtoolssupport_v >= 610.0} {
134                                                # for now, we don't need to distinguish 2.1 from 2.1 or higher.
135                                                set darwinports::xcodeversion "2.1"
136                                        } else {
137                                                set darwinports::xcodeversion "2.0orlower"
138                                        }
139                                } else {
140                                        set darwinports::xcodeversion "2.0orlower"
141                                }
142                        } else {
143                                set darwinports::xcodeversion "2.0orlower"
144                        }
145                }
146               
147                if {![info exists xcodebuildcmd]} {
148                        set darwinports::xcodebuildcmd "xcodebuild"
149                }
150        } elseif {[catch {set pbxbuild [binaryInPath "pbxbuild"]}] == 0} {
151                if {![info exists xcodeversion]} {
152                        set darwinports::xcodeversion "pb"
153                }
154                if {![info exists xcodebuildcmd]} {
155                        set darwinports::xcodebuildcmd "pbxbuild"
156                }
157        } else {
158                if {![info exists xcodeversion]} {
159                        set darwinports::xcodeversion "none"
160                }
161                if {![info exists xcodebuildcmd]} {
162                        set darwinports::xcodebuildcmd "none"
163                }
164        }
165}
166
167proc dportinit {up_ui_options up_options up_variations} {
168        upvar  $up_ui_options ui_options
169        upvar  $up_options        options
170        upvar  $up_variations variations
171       
172        global auto_path env
173        global darwinports::autoconf::dports_conf_path
174        global darwinports::bootstrap_options
175        global darwinports::extra_env
176        global darwinports::portconf
177        global darwinports::portdbpath
178        global darwinports::portsharepath
179        global darwinports::registry.format
180        global darwinports::registry.path
181        global darwinports::sources
182        global darwinports::sources_conf
183        global darwinports::startupitem_type
184        global darwinports::destroot_umask
185        global darwinports::libpath
186        global darwinports::prefix
187        global darwinports::registry.installtype
188        global darwinports::rsync_dir
189        global darwinports::rsync_options
190        global darwinports::rsync_server
191        global darwinports::variants_conf
192        global darwinports::xcodebuildcmd
193        global darwinports::xcodeversion
194
195    # first look at PORTSRC for testing/debugging
196    if {[llength [array names env PORTSRC]] > 0} {
197        set PORTSRC [lindex [array get env PORTSRC] 1]
198        if {[file isfile ${PORTSRC}]} {
199            set portconf ${PORTSRC}
200            lappend conf_files ${portconf}
201        }
202    }
203
204    # then look in ~/.portsrc
205    if {![info exists portconf]} {
206        if {[llength [array names env HOME]] > 0} {
207            set HOME [lindex [array get env HOME] 1]
208            if {[file isfile [file join ${HOME} .portsrc]]} {
209                set portconf [file join ${HOME} .portsrc]
210                lappend conf_files ${portconf}
211            }
212        }
213    }
214
215    # finally /etc/ports/ports.conf, or whatever path was configured
216    if {![info exists portconf]} {
217        if {[file isfile $dports_conf_path/ports.conf]} {
218            set portconf $dports_conf_path/ports.conf
219            lappend conf_files $dports_conf_path/ports.conf
220        }
221    }
222    if {[info exists conf_files]} {
223        foreach file $conf_files {
224            set fd [open $file r]
225            while {[gets $fd line] >= 0} {
226                foreach option $bootstrap_options {
227                    if {[regexp "^$option\[ \t\]+(\[A-Za-z0-9_:,\./-\]+$)" $line match val] == 1} {
228                        set darwinports::$option $val
229                        global darwinports::$option
230                    }
231                }
232            }
233        }
234    }
235
236    if {![info exists sources_conf]} {
237        return -code error "sources_conf must be set in $dports_conf_path/ports.conf or in your ~/.portsrc"
238    }
239    if {[catch {set fd [open $sources_conf r]} result]} {
240        return -code error "$result"
241    }
242    while {[gets $fd line] >= 0} {
243        set line [string trimright $line]
244        if {![regexp {[\ \t]*#.*|^$} $line]} {
245            lappend sources $line
246        }
247    }
248    if {![info exists sources]} {
249        if {[file isdirectory dports]} {
250            set sources "file://[pwd]/dports"
251        } else {
252            return -code error "No sources defined in $sources_conf"
253        }
254    }
255
256        if {[info exists variants_conf]} {
257                if {[file exist $variants_conf]} {
258                        if {[catch {set fd [open $variants_conf r]} result]} {
259                                return -code error "$result"
260                        }
261                        while {[gets $fd line] >= 0} {
262                                set line [string trimright $line]
263                                if {![regexp {^[\ \t]*#.*$|^$} $line]} {
264                                        foreach arg [split $line " \t"] {
265                                                if {[regexp {^([-+])([-A-Za-z0-9_+\.]+)$} $arg match sign opt] == 1} {
266                                                        if {![info exists variations($opt)]} {
267                                                                set variations($opt) $sign
268                                                        }
269                                                } else {
270                                                        ui_warn "$variants_conf specifies invalid variant syntax '$arg', ignored."
271                                                }
272                                        }
273                                }
274                        }
275                } else {
276                        ui_debug "$variants_conf does not exist, variants_conf setting ignored."
277                }
278        }
279
280    if {![info exists portdbpath]} {
281        return -code error "portdbpath must be set in $dports_conf_path/ports.conf or in your ~/.portsrc"
282    }
283    if {![file isdirectory $portdbpath]} {
284        if {![file exists $portdbpath]} {
285            if {[catch {file mkdir $portdbpath} result]} {
286                return -code error "portdbpath $portdbpath does not exist and could not be created: $result"
287            }
288        }
289    }
290    if {![file isdirectory $portdbpath]} {
291        return -code error "$portdbpath is not a directory. Please create the directory $portdbpath and try again"
292    }
293
294    set registry.path $portdbpath
295    if {![file isdirectory ${registry.path}]} {
296        if {![file exists ${registry.path}]} {
297            if {[catch {file mkdir ${registry.path}} result]} {
298                return -code error "portdbpath ${registry.path} does not exist and could not be created: $result"
299            }
300        }
301    }
302    if {![file isdirectory ${darwinports::registry.path}]} {
303        return -code error "${darwinports::registry.path} is not a directory. Please create the directory $portdbpath and try again"
304    }
305
306        # Format for receipts, can currently be either "flat" or "sqlite"
307        if {[info exists portdbformat]} {
308                if { $portdbformat == "sqlite" } {
309                        return -code error "SQLite is not yet supported for registry storage."
310                } 
311                set registry.format receipt_${portdbformat}
312        } else {
313                set registry.format receipt_flat
314        }
315
316        # Installation type, whether to use port "images" or install "direct"
317        if {[info exists portinstalltype]} {
318                set registry.installtype $portinstalltype
319        } else {
320                set registry.installtype image
321        }
322   
323        # Autoclean mode, whether to automatically call clean after "install"
324        if {![info exists portautoclean]} {
325                set darwinports::portautoclean "yes"
326                global darwinports::portautoclean
327        }
328        # Check command line override for autoclean
329        if {[info exists options(ports_autoclean)]} {
330                if {![string equal $options(ports_autoclean) $portautoclean]} {
331                        set darwinports::portautoclean $options(ports_autoclean)
332                }
333        }
334        # Trace mode, whether to use darwintrace to debug ports.
335        if {![info exists porttrace]} {
336                set darwinports::porttrace "no"
337                global darwinports::porttrace
338        }
339        # Check command line override for trace
340        if {[info exists options(ports_trace)]} {
341                if {![string equal $options(ports_trace) $porttrace]} {
342                        set darwinports::porttrace $options(ports_trace)
343                }
344        }
345
346        # Export verbosity.
347        if {![info exists portverbose]} {
348                set darwinports::portverbose "no"
349                global darwinports::portverbose
350        }
351        if {[info exists ui_options(ports_verbose)]} {
352                if {![string equal $ui_options(ports_verbose) $portverbose]} {
353                        set darwinports::portverbose $ui_options(ports_verbose)
354                }
355        }
356
357        # Archive mode, whether to create/use binary archive packages
358        if {![info exists portarchivemode]} {
359                set darwinports::portarchivemode "yes"
360                global darwinports::portarchivemode
361        }
362
363        # Archive path, where to store/retrieve binary archive packages
364        if {![info exists portarchivepath]} {
365                set darwinports::portarchivepath [file join $portdbpath packages]
366                global darwinports::portarchivepath
367        }
368        if {$portarchivemode == "yes"} {
369                if {![file isdirectory $portarchivepath]} {
370                        if {![file exists $portarchivepath]} {
371                                if {[catch {file mkdir $portarchivepath} result]} {
372                                        return -code error "portarchivepath $portarchivepath does not exist and could not be created: $result"
373                                }
374                        }
375                }
376                if {![file isdirectory $portarchivepath]} {
377                        return -code error "$portarchivepath is not a directory. Please create the directory $portarchivepath and try again"
378                }
379        }
380
381        # Archive type, what type of binary archive to use (CPIO, gzipped
382        # CPIO, XAR, etc.)
383        if {![info exists portarchivetype]} {
384                set darwinports::portarchivetype "cpgz"
385                global darwinports::portarchivetype
386        }
387        # Convert archive type to a list for multi-archive support, colon or
388        # comma separators indicates to use multiple archive formats
389        # (reading and writing)
390        set darwinports::portarchivetype [split $portarchivetype {:,}]
391
392        # Set rync options
393        if {![info exists rsync_server]} {
394                set darwinports::rsync_server rsync.darwinports.org
395                global darwinports::rsync_server
396        }
397        if {![info exists rsync_dir]} {
398                set darwinports::rsync_dir dpupdate1/base/
399                global darwinports::rsync_dir
400        }
401        if {![info exists rsync_options]} {
402                set rsync_options "-rtzv --delete --delete-after"
403                global darwinports::rsync_options
404        }
405
406    set portsharepath ${prefix}/share/darwinports
407    if {![file isdirectory $portsharepath]} {
408        return -code error "Data files directory '$portsharepath' must exist"
409    }
410   
411    if {![info exists libpath]} {
412        set libpath "${prefix}/share/darwinports/Tcl"
413    }
414
415    if {![info exists binpath]} {
416        set env(PATH) "${prefix}/bin:${prefix}/sbin:/bin:/sbin:/usr/bin:/usr/sbin:/usr/X11R6/bin"
417    } else {
418        set env(PATH) "$binpath"
419    }
420   
421    # Set startupitem default type (can be overridden by portfile)
422    if {![info exists startupitem_type]} {
423        set darwinports::startupitem_type "default"
424        global darwinports::startupitem_type
425    }
426   
427    # ENV cleanup.
428        set keepenvkeys { DISPLAY DYLD_FALLBACK_FRAMEWORK_PATH
429                          DYLD_FALLBACK_LIBRARY_PATH DYLD_FRAMEWORK_PATH
430                          DYLD_LIBRARY_PATH HOME JAVA_HOME LD_PREBIND
431                          LD_PREBIND_ALLOW_OVERLAP MASTER_SITE_LOCAL
432                          PATCH_SITE_LOCAL PATH PORTSRC RSYNC_PROXY TMP TMPDIR
433                          USER GROUP http_proxy https_proxy ftp_proxy all_proxy
434                          no_proxy
435        }
436    if {[info exists extra_env]} {
437        lappend keepenvkeys ${extra_env}
438    }
439
440        foreach envkey [array names env] {
441                if {[lsearch $keepenvkeys $envkey] == -1} {
442                        array unset env $envkey
443                }
444        }
445
446        if {![info exists xcodeversion] || ![info exists xcodebuildcmd]} {
447                # We'll resolve these later (if needed)
448                trace add variable darwinports::xcodeversion read darwinports::setxcodeinfo
449                trace add variable darwinports::xcodebuildcmd read darwinports::setxcodeinfo
450        }
451
452    # Set the default umask
453    if {![info exists destroot_umask]} {
454        set destroot_umask 022
455    }
456
457    if {[info exists master_site_local] && ![info exists env(MASTER_SITE_LOCAL)]} {
458        set env(MASTER_SITE_LOCAL) "$master_site_local"
459    }
460
461        # Prebinding. useful with MacOS X's ld, harmless elsewhere.
462        # With both variables, prebinding will always succeed but we might need
463        # to redo it.
464    if {![info exists env(LD_PREBIND)] && ![info exists env(LD_PREBIND_ALLOW_OVERLAP)]} {
465        set env(LD_PREBIND) "1"
466        set env(LD_PREBIND_ALLOW_OVERLAP) "1"
467    }
468
469    if {[file isdirectory $libpath]} {
470                lappend auto_path $libpath
471                set darwinports::auto_path $auto_path
472
473                # XXX: not sure if this the best place, but it needs to happen
474                # early, and after auto_path has been set.  Or maybe Pextlib
475                # should ship with darwinports1.0 API?
476                package require Pextlib 1.0
477                package require registry 1.0
478    } else {
479                return -code error "Library directory '$libpath' must exist"
480    }
481}
482
483proc darwinports::worker_init {workername portpath portbuildpath options variations} {
484    global darwinports::portinterp_options darwinports::portinterp_deferred_options registry.installtype
485
486        # Tell the sub interpreter about all the Tcl packages we already
487        # know about so it won't glob for packages.
488        foreach pkgName [package names] {
489                foreach pkgVers [package versions $pkgName] {
490                        set pkgLoadScript [package ifneeded $pkgName $pkgVers]
491                        $workername eval "package ifneeded $pkgName $pkgVers {$pkgLoadScript}"
492                }
493        }
494
495    # Create package require abstraction procedure
496    $workername eval "proc PortSystem \{version\} \{ \n\
497                        package require port \$version \}"
498
499    # Clearly separate slave interpreters and the master interpreter.
500        $workername alias dport_exec dportexec
501        $workername alias dport_open dportopen
502        $workername alias dport_close dportclose
503        $workername alias dport_search dportsearch
504
505    # instantiate the UI call-backs
506        foreach priority ${darwinports::ui_priorities} {
507                $workername alias ui_$priority ui_$priority
508        }
509        $workername alias ui_prefix ui_prefix
510        $workername alias ui_channels ui_channels
511   
512    # Export some utility functions defined here.
513    $workername alias darwinports_create_thread darwinports::create_thread
514
515        # New Registry/Receipts stuff
516        $workername alias registry_new registry::new_entry
517        $workername alias registry_open registry::open_entry
518        $workername alias registry_write registry::write_entry
519        $workername alias registry_prop_store registry::property_store
520        $workername alias registry_prop_retr registry::property_retrieve
521        $workername alias registry_delete registry::delete_entry
522        $workername alias registry_exists registry::entry_exists
523        $workername alias registry_activate portimage::activate
524        $workername alias registry_deactivate portimage::deactivate
525        $workername alias registry_register_deps registry::register_dependencies
526        $workername alias registry_fileinfo_for_index registry::fileinfo_for_index
527        $workername alias registry_bulk_register_files registry::register_bulk_files
528        $workername alias registry_installed registry::installed
529
530        # deferred options processing.
531        $workername alias getoption darwinports::getoption
532
533    foreach opt $portinterp_options {
534                if {![info exists $opt]} {
535                    global darwinports::$opt
536                }
537        if {[info exists $opt]} {
538            $workername eval set system_options($opt) \"[set $opt]\"
539            $workername eval set $opt \"[set $opt]\"
540        }
541    }
542   
543        foreach opt $portinterp_deferred_options {
544                global darwinports::$opt
545                # define the trace hook.
546                $workername eval \
547                        "proc trace_$opt {name1 name2 op} { \n\
548                                trace remove variable ::$opt read ::trace_$opt \n\
549                                global $opt \n\
550                                set $opt \[getoption $opt\] \n\
551                        }"
552                # next access will actually define the variable.
553                $workername eval "trace add variable ::$opt read ::trace_$opt"
554                # define some value now
555                $workername eval set $opt "?"
556        }               
557
558    foreach {opt val} $options {
559        $workername eval set user_options($opt) $val
560        $workername eval set $opt $val
561    }
562
563    foreach {var val} $variations {
564        $workername eval set variations($var) $val
565    }
566
567    if { [info exists registry.installtype] } {
568            $workername eval set installtype ${registry.installtype}
569    }
570}
571
572# Create a thread with most configuration options set.
573# The newly created thread is sent portinterp_options vars and knows where to
574# find all packages we know.
575proc darwinports::create_thread {} {
576    package require Thread
577
578    global darwinports::portinterp_options
579
580        # Create the thread.
581        set result [thread::create -preserved {thread::wait}]
582
583        # Tell the thread about all the Tcl packages we already
584        # know about so it won't glob for packages.
585        foreach pkgName [package names] {
586                foreach pkgVers [package versions $pkgName] {
587                        set pkgLoadScript [package ifneeded $pkgName $pkgVers]
588                        thread::send -async $result "package ifneeded $pkgName $pkgVers {$pkgLoadScript}"
589                }
590        }
591
592        # inherit configuration variables.
593        thread::send -async $result "namespace eval darwinports {}"
594        foreach opt $portinterp_options {
595                if {![info exists $opt]} {
596                        global darwinports::$opt
597                }
598        if {[info exists $opt]} {
599                        thread::send -async $result "global darwinports::$opt"
600                        set val [set darwinports::$opt]
601                        thread::send -async $result "set darwinports::$opt \"$val\""
602                }
603        }
604       
605        return $result
606}
607
608proc darwinports::fetch_port {url} {
609    global darwinports::portdbpath tcl_platform
610    set fetchdir [file join $portdbpath portdirs]
611    set fetchfile [file tail $url]
612    if {[catch {file mkdir $fetchdir} result]} {
613        return -code error $result
614    }
615    if {![file writable $fetchdir]} {
616        return -code error "Port remote fetch failed: You do not have permission to write to $fetchdir"
617    }
618    if {[catch {exec curl -L -s -S -o [file join $fetchdir $fetchfile] $url} result]} {
619        return -code error "Port remote fetch failed: $result"
620    }
621    if {[catch {cd $fetchdir} result]} {
622        return -code error $result
623    }
624    if {[catch {exec tar -zxf $fetchfile} result]} {
625        return -code error "Port extract failed: $result"
626    }
627    if {[regexp {(.+).tgz} $fetchfile match portdir] != 1} {
628        return -code error "Can't decipher portdir from $fetchfile"
629    }
630    return [file join $fetchdir $portdir]
631}
632
633proc darwinports::getprotocol {url} {
634    if {[regexp {(?x)([^:]+)://.+} $url match protocol] == 1} {
635        return ${protocol}
636    } else {
637        return -code error "Can't parse url $url"
638    }
639}
640
641# XXX: this really needs to be rethought in light of the remote index
642# I've added the destdir parameter.  This is the location a remotely
643# fetched port will be downloaded to (currently only applies to
644# dports:// sources).
645proc darwinports::getportdir {url {destdir "."}} {
646        if {[regexp {(?x)([^:]+)://(.+)} $url match protocol string] == 1} {
647                switch -regexp -- ${protocol} {
648                        {^file$} {
649                                return $string
650                        }
651                        {^dports$} {
652                                return [darwinports::index::fetch_port $url $destdir]
653                        }
654                        {^https?$|^ftp$} {
655                                return [darwinports::fetch_port $url]
656                        }
657                        default {
658                                return -code error "Unsupported protocol $protocol"
659                        }
660                }
661        } else {
662                return -code error "Can't parse url $url"
663        }
664}
665
666# dportopen
667# Opens a DarwinPorts portfile specified by a URL.  The portfile is
668# opened with the given list of options and variations.  The result
669# of this function should be treated as an opaque handle to a
670# DarwinPorts Portfile.
671
672proc dportopen {porturl {options ""} {variations ""} {nocache ""}} {
673    global darwinports::portdbpath darwinports::portconf darwinports::open_dports auto_path
674
675        # Look for an already-open DPort with the same URL.
676        # XXX: should compare options and variations here too.
677        # if found, return the existing reference and bump the refcount.
678        if {$nocache != ""} {
679                set dport {}
680        } else {
681                set dport [dlist_search $darwinports::open_dports porturl $porturl]
682        }
683        if {$dport != {}} {
684                set refcnt [ditem_key $dport refcnt]
685                incr refcnt
686                ditem_key $dport refcnt $refcnt
687                return $dport
688        }
689
690        array set options_array $options
691        if {[info exists options_array(portdir)]} {
692                set portdir $options_array(portdir)
693        } else {
694                set portdir ""
695        }
696
697        set portdir [darwinports::getportdir $porturl $portdir]
698        ui_debug "Changing to port directory: $portdir"
699        cd $portdir
700        set portpath [pwd]
701        set workername [interp create]
702
703        set dport [ditem_create]
704        lappend darwinports::open_dports $dport
705        ditem_key $dport porturl $porturl
706        ditem_key $dport portpath $portpath
707        ditem_key $dport workername $workername
708        ditem_key $dport options $options
709        ditem_key $dport variations $variations
710        ditem_key $dport refcnt 1
711
712    darwinports::worker_init $workername $portpath [darwinports::getportbuildpath $portpath] $options $variations
713    if {![file isfile Portfile]} {
714        return -code error "Could not find Portfile in $portdir"
715    }
716
717    $workername eval source Portfile
718       
719    ditem_key $dport provides [$workername eval return \$portname]
720
721    return $dport
722}
723
724# Traverse a directory with ports, calling a function on the path of ports
725# (at the second depth).
726# I.e. the structure of dir shall be:
727# category/port/
728# with a Portfile file in category/port/
729#
730# func:         function to call on every port directory (it is passed
731#                       category/port/ as its parameter)
732# root:         the directory with all the categories directories.
733proc dporttraverse {func {root .}} {
734        # Save the current directory
735        set pwd [pwd]
736       
737        # Join the root.
738        set pathToRoot [file join $pwd $root]
739
740        # Go to root because some callers expects us to be there.
741        cd $pathToRoot
742
743    foreach category [lsort -increasing -unique [readdir $root]] {
744        set pathToCategory [file join $root $category]
745        if {[file isdirectory $pathToCategory]} {
746                # Iterate on port directories.
747                        foreach port [lsort -increasing -unique [readdir $pathToCategory]] {
748                                set pathToPort [file join $pathToCategory $port]
749                                if {[file isdirectory $pathToPort] &&
750                                        [file exists [file join $pathToPort "Portfile"]]} {
751                                        # Call the function.
752                                        $func [file join $category $port]
753                                       
754                                        # Restore the current directory because some
755                                        # functions changes it.
756                                        cd $pathToRoot
757                                }
758                        }
759        }
760        }
761       
762        # Restore the current directory.
763        cd $pwd
764}
765
766### _dportsearchpath is private; subject to change without notice
767
768# depregex -> regex on the filename to find.
769# search_path -> directories to search
770# executable -> whether we want to check that the file is executable by current
771#                               user or not.
772proc _dportsearchpath {depregex search_path {executable 0}} {
773    set found 0
774    foreach path $search_path {
775        if {![file isdirectory $path]} {
776            continue
777        }
778
779        if {[catch {set filelist [readdir $path]} result]} {
780                return -code error "$result ($path)"
781                set filelist ""
782        }
783
784        foreach filename $filelist {
785            if {[regexp $depregex $filename] &&
786                (($executable == 0) || [file executable [file join $path $filename]])} {
787                ui_debug "Found Dependency: path: $path filename: $filename regex: $depregex"
788                set found 1
789                break
790            }
791        }
792    }
793    return $found
794}
795
796### _libtest is private; subject to change without notice
797# XXX - Architecture specific
798# XXX - Rely on information from internal defines in cctools/dyld:
799# define DEFAULT_FALLBACK_FRAMEWORK_PATH
800# /Library/Frameworks:/Library/Frameworks:/Network/Library/Frameworks:/System/Library/Frameworks
801# define DEFAULT_FALLBACK_LIBRARY_PATH /lib:/usr/local/lib:/lib:/usr/lib
802#   -- Since /usr/local is bad, using /lib:/usr/lib only.
803# Environment variables DYLD_FRAMEWORK_PATH, DYLD_LIBRARY_PATH,
804# DYLD_FALLBACK_FRAMEWORK_PATH, and DYLD_FALLBACK_LIBRARY_PATH take precedence
805
806proc _libtest {dport depspec} {
807    global env tcl_platform
808        set depline [lindex [split $depspec :] 1]
809        set prefix [_dportkey $dport prefix]
810       
811        if {[info exists env(DYLD_FRAMEWORK_PATH)]} {
812            lappend search_path $env(DYLD_FRAMEWORK_PATH)
813        } else {
814            lappend search_path /Library/Frameworks /Network/Library/Frameworks /System/Library/Frameworks
815        }
816        if {[info exists env(DYLD_FALLBACK_FRAMEWORK_PATH)]} {
817            lappend search_path $env(DYLD_FALLBACK_FRAMEWORK_PATH)
818        }
819        if {[info exists env(DYLD_LIBRARY_PATH)]} {
820            lappend search_path $env(DYLD_LIBRARY_PATH)
821        }
822        lappend search_path /lib /usr/lib /usr/X11R6/lib ${prefix}/lib
823        if {[info exists env(DYLD_FALLBACK_LIBRARY_PATH)]} {
824            lappend search_path $env(DYLD_FALLBACK_LIBRARY_PATH)
825        }
826
827        set i [string first . $depline]
828        if {$i < 0} {set i [string length $depline]}
829        set depname [string range $depline 0 [expr $i - 1]]
830        set depversion [string range $depline $i end]
831        regsub {\.} $depversion {\.} depversion
832        if {$tcl_platform(os) == "Darwin"} {
833                set depregex \^${depname}${depversion}\\.dylib\$
834        } else {
835                set depregex \^${depname}\\.so${depversion}\$
836        }
837
838        return [_dportsearchpath $depregex $search_path]
839}
840
841### _bintest is private; subject to change without notice
842
843proc _bintest {dport depspec} {
844    global env
845        set depregex [lindex [split $depspec :] 1]
846        set prefix [_dportkey $dport prefix] 
847       
848        set search_path [split $env(PATH) :]
849       
850        set depregex \^$depregex\$
851       
852        return [_dportsearchpath $depregex $search_path 1]
853}
854
855### _pathtest is private; subject to change without notice
856
857proc _pathtest {dport depspec} {
858    global env
859        set depregex [lindex [split $depspec :] 1]
860        set prefix [_dportkey $dport prefix] 
861   
862        # separate directory from regex
863        set fullname $depregex
864
865        regexp {^(.*)/(.*?)$} "$fullname" match search_path depregex
866
867        if {[string index $search_path 0] != "/"} {
868                # Prepend prefix if not an absolute path
869                set search_path "${prefix}/${search_path}"
870        }
871
872        set depregex \^$depregex\$
873
874        return [_dportsearchpath $depregex $search_path]
875}
876
877### _porttest is private; subject to change without notice
878
879proc _porttest {dport depspec} {
880        # We don't actually look for the port, but just return false
881        # in order to let the dportdepends handle the dependency
882        return 0
883}
884
885### _dportinstalled is private; may change without notice
886
887# Determine if a port is already *installed*, as in "in the registry".
888proc _dportinstalled {dport} {
889        # Check for the presense of the port in the registry
890        set workername [ditem_key $dport workername]
891        set res [$workername eval registry_exists \${portname} \${portversion}]
892        if {$res != 0} {
893                ui_debug "[ditem_key $dport provides] is installed"
894                return 1
895        } else {
896                return 0
897        }
898}
899
900### _dportispresent is private; may change without notice
901
902# Determine if some depspec is satisfied or if the given port is installed.
903# We actually start with the registry (faster?)
904#
905# dport         the port to test (to figure out if it's present)
906# depspec       the dependency test specification (path, bin, lib, etc.)
907proc _dportispresent {dport depspec} {
908        # Check for the presense of the port in the registry
909        set workername [ditem_key $dport workername]
910        ui_debug "Searching for dependency: [ditem_key $dport provides]"
911        if {[catch {set reslist [$workername eval registry_installed \${portname}]} res]} {
912                set res 0
913        } else {
914                set res [llength $reslist]
915        }
916        if {$res != 0} {
917                ui_debug "Found Dependency: receipt exists for [ditem_key $dport provides]"
918                return 1
919        } else {
920                # The receipt test failed, use one of the depspec regex mechanisms
921                ui_debug "Didn't find receipt, going to depspec regex for: [ditem_key $dport provides]"
922                set type [lindex [split $depspec :] 0]
923                switch $type {
924                        lib { return [_libtest $dport $depspec] }
925                        bin { return [_bintest $dport $depspec] }
926                        path { return [_pathtest $dport $depspec] }
927                        port { return [_porttest $dport $depspec] }
928                        default {return -code error "unknown depspec type: $type"}
929                }
930                return 0
931        }
932}
933
934### _dportexec is private; may change without notice
935
936proc _dportexec {target dport} {
937        # xxx: set the work path?
938        set workername [ditem_key $dport workername]
939        if {![catch {$workername eval eval_variants variations $target} result] && $result == 0 &&
940                ![catch {$workername eval eval_targets $target} result] && $result == 0} {
941                # If auto-clean mode, clean-up after dependency install
942                if {[string equal ${darwinports::portautoclean} "yes"]} {
943                        # Make sure we are back in the port path before clean
944                        # otherwise if the current directory had been changed to
945                        # inside the port,  the next port may fail when trying to
946                        # install because [pwd] will return a "no file or directory"
947                        # error since the directory it was in is now gone.
948                        set portpath [ditem_key $dport portpath]
949                        catch {cd $portpath}
950                        $workername eval eval_targets clean
951                }
952                return 0
953        } else {
954                # An error occurred.
955                return 1
956        }
957}
958
959# dportexec
960# Execute the specified target of the given dport.
961
962proc dportexec {dport target} {
963    global darwinports::registry.installtype
964
965        set workername [ditem_key $dport workername]
966
967        # XXX: move this into dportopen?
968        if {[$workername eval eval_variants variations $target] != 0} {
969                return 1
970        }
971       
972        # Before we build the port, we must build its dependencies.
973        # XXX: need a more general way of comparing against targets
974        set dlist {}
975        if {$target == "package"} {
976                ui_warn "package target replaced by pkg target, please use the pkg target in the future."
977                set target "pkg"
978        }
979        if {$target == "configure" || $target == "build"
980                || $target == "destroot" || $target == "install"
981                || $target == "archive"
982                || $target == "pkg" || $target == "mpkg"
983                || $target == "rpmpackage" || $target == "dpkg" } {
984
985                if {[dportdepends $dport $target] != 0} {
986                        return 1
987                }
988               
989                # Select out the dependents along the critical path,
990                # but exclude this dport, we might not be installing it.
991                set dlist [dlist_append_dependents $darwinports::open_dports $dport {}]
992               
993                dlist_delete dlist $dport
994
995                # install them
996                # xxx: as with below, this is ugly.  and deps need to be fixed to
997                # understand Port Images before this can get prettier
998                if { [string equal ${darwinports::registry.installtype} "image"] } {
999                        set result [dlist_eval $dlist _dportinstalled [list _dportexec "activate"]]
1000                } else {
1001                        set result [dlist_eval $dlist _dportinstalled [list _dportexec "install"]]
1002                }
1003               
1004                if {$result != {}} {
1005                        set errstring "The following dependencies failed to build:"
1006                        foreach ditem $result {
1007                                append errstring " [ditem_key $ditem provides]"
1008                        }
1009                        ui_error $errstring
1010                        return 1
1011                }
1012               
1013                # Close the dependencies, we're done installing them.
1014                foreach ditem $dlist {
1015                        dportclose $ditem
1016                }
1017        }
1018
1019        # If we're doing an install, check if we should clean after
1020        set clean 0
1021        if {[string equal ${darwinports::portautoclean} "yes"] && [string equal $target "install"] } {
1022                set clean 1
1023        }
1024
1025        # If we're doing image installs, then we should activate after install
1026        # xxx: This isn't pretty
1027        if { [string equal ${darwinports::registry.installtype} "image"] && [string equal $target "install"] } {
1028                set target activate
1029        }
1030       
1031        # Build this port with the specified target
1032        set result [$workername eval eval_targets $target]
1033
1034        # If auto-clean mode and successful install, clean-up after install
1035        if {$result == 0 && $clean == 1} {
1036                # Make sure we are back in the port path, just in case
1037                set portpath [ditem_key $dport portpath]
1038                catch {cd $portpath}
1039                $workername eval eval_targets clean
1040        }
1041
1042        return $result
1043}
1044
1045proc darwinports::getsourcepath {url} {
1046        global darwinports::portdbpath
1047        regsub {://} $url {.} source_path
1048        regsub -all {/} $source_path {_} source_path
1049        return [file join $portdbpath sources $source_path]
1050}
1051
1052proc darwinports::getportbuildpath {id} {
1053        global darwinports::portdbpath
1054        regsub {://} $id {.} port_path
1055        regsub -all {/} $port_path {_} port_path
1056        return [file join $portdbpath build $port_path]
1057}
1058
1059proc darwinports::getindex {source} {
1060        # Special case file:// sources
1061        if {[darwinports::getprotocol $source] == "file"} {
1062                return [file join [darwinports::getportdir $source] PortIndex]
1063        }
1064
1065        return [file join [darwinports::getsourcepath $source] PortIndex]
1066}
1067
1068proc dportsync {args} {
1069        global darwinports::sources darwinports::portdbpath tcl_platform
1070
1071        foreach source $sources {
1072                ui_info "Synchronizing from $source"
1073                switch -regexp -- [darwinports::getprotocol $source] {
1074                        {^file$} {
1075                                continue
1076                        }
1077                        {^dports$} {
1078                                darwinports::index::sync $darwinports::portdbpath $source
1079                        }
1080                        {^rsync$} {
1081                                # Where to, boss?
1082                                set destdir [file dirname [darwinports::getindex $source]]
1083
1084                                if {[catch {file mkdir $destdir} result]} {
1085                                        return -code error $result
1086                                }
1087
1088                                # Keep rsync happy with a trailing slash
1089                                if {[string index $source end] != "/"} {
1090                                        set source "${source}/"
1091                                }
1092
1093                                # Do rsync fetch
1094                                if {[catch {system "rsync -rtzv --delete-after --delete \"$source\" \"$destdir\""}]} {
1095                                        return -code error "sync failed doing rsync"
1096                                }
1097                        }
1098                        {^https?$|^ftp$} {
1099                                set indexfile [darwinports::getindex $source]
1100                                if {[catch {file mkdir [file dirname $indexfile]} result]} {
1101                                        return -code error $result
1102                                }
1103                                exec curl -L -s -S -o $indexfile $source/PortIndex
1104                        }
1105                }
1106        }
1107}
1108
1109proc dportsearch {pattern {case_sensitive yes} {matchstyle regexp} {field name}} {
1110        global darwinports::portdbpath darwinports::sources
1111        set matches [list]
1112        set easy [expr { $field == "name" }]
1113       
1114        set found 0
1115        foreach source $sources {
1116                if {[darwinports::getprotocol $source] == "dports"} {
1117                        array set attrs [list name $pattern]
1118                        set res [darwinports::index::search $darwinports::portdbpath $source [array get attrs]]
1119                        eval lappend matches $res
1120                } else {
1121                        if {[catch {set fd [open [darwinports::getindex $source] r]} result]} {
1122                                ui_warn "Can't open index file for source: $source"
1123                        } else {
1124                                incr found 1
1125                                while {[gets $fd line] >= 0} {
1126                                        set name [lindex $line 0]
1127                                        gets $fd line
1128                                       
1129                                        if {$easy} {
1130                                                set target $name
1131                                        } else {
1132                                                array set portinfo $line
1133                                                if {![info exists portinfo($field)]} continue
1134                                                set target $portinfo($field)
1135                                        }
1136                                       
1137                                        switch $matchstyle {
1138                                                exact   { set matchres [expr 0 == ( {$case_sensitive == "yes"} ? [string compare $pattern $target] : [string compare -nocase $pattern $target] )] }
1139                                                glob    { set matchres [expr {$case_sensitive == "yes"} ? [string match $pattern $target] : [string match -nocase $pattern $target]] }
1140                                                regexp  -
1141                                                default { set matchres [expr {$case_sensitive == "yes"} ? [regexp -- $pattern $target] : [regexp -nocase -- $pattern $target]] }
1142                                        }
1143                                       
1144                                        if {$matchres == 1} {
1145                                                if {$easy} {
1146                                                        array set portinfo $line
1147                                                }
1148                                                switch -regexp -- [darwinports::getprotocol ${source}] {
1149                                                        {^rsync$} {
1150                                                                # Rsync files are local
1151                                                                set source_url "file://[darwinports::getsourcepath $source]"
1152                                                        }
1153                                                        default {
1154                                                                set source_url $source
1155                                                        }
1156                                                }
1157                                                if {[info exists portinfo(portarchive)]} {
1158                                                        set porturl ${source_url}/$portinfo(portarchive)
1159                                                } elseif {[info exists portinfo(portdir)]} {
1160                                                        set porturl ${source_url}/$portinfo(portdir)
1161                                                }
1162                                                if {[info exists porturl]} {
1163                                                        lappend line porturl $porturl
1164                                                        ui_debug "Found port in $porturl"
1165                                                } else {
1166                                                        ui_debug "Found port info: $line"
1167                                                }
1168                                                lappend matches $name
1169                                                lappend matches $line
1170                                        }
1171                                }
1172                                close $fd
1173                        }
1174                }
1175        }
1176        if {!$found} {
1177                return -code error "No index(es) found! Have you synced your source indexes?"
1178        }
1179
1180        return $matches
1181}
1182
1183proc dportinfo {dport} {
1184        set workername [ditem_key $dport workername]
1185    return [$workername eval array get PortInfo]
1186}
1187
1188proc dportclose {dport} {
1189        global darwinports::open_dports
1190        set refcnt [ditem_key $dport refcnt]
1191        incr refcnt -1
1192        ditem_key $dport refcnt $refcnt
1193        if {$refcnt == 0} {
1194                dlist_delete darwinports::open_dports $dport
1195                set workername [ditem_key $dport workername]
1196                interp delete $workername
1197        }
1198}
1199
1200##### Private Depspec API #####
1201# This API should be considered work in progress and subject to change without notice.
1202##### "
1203
1204# _dportkey
1205# - returns a variable from the port's interpreter
1206
1207proc _dportkey {dport key} {
1208        set workername [ditem_key $dport workername]
1209        return [$workername eval "return \$${key}"]
1210}
1211
1212# dportdepends builds the list of dports which the given port depends on.
1213# This list is added to $dport.
1214# This list actually depends on the target.
1215# This method can optionally recurse through the dependencies, looking for
1216#   dependencies of dependencies.
1217# This method can optionally cut the search when ports are already installed or
1218#   the dependencies are satisfied.
1219#
1220# dport -> dport item
1221# target -> target to consider the dependency for
1222# recurseDeps -> if the search should be recursive
1223# skipSatisfied -> cut the search tree when encountering installed/satisfied
1224#                  dependencies ports.
1225# accDeps -> accumulator for recursive calls
1226# return 0 if everything was ok, an non zero integer otherwise.
1227proc dportdepends {dport {target ""} {recurseDeps 1} {skipSatisfied 1} {accDeps {}}} {
1228
1229        array set portinfo [dportinfo $dport]
1230        set depends {}
1231        set deptypes {}
1232       
1233        # Determine deptypes to look for based on target
1234        switch $target {
1235                configure       { set deptypes "depends_lib" }
1236               
1237                build           { set deptypes "depends_lib depends_build" }
1238               
1239                destroot        -
1240                install         -
1241                archive         -
1242                pkg                     -
1243                mpkg            -
1244                rpmpackage      -
1245                dpkg            -
1246                ""                      { set deptypes "depends_lib depends_build depends_run" }
1247        }
1248       
1249        # Gather the dependencies for deptypes
1250        foreach deptype $deptypes {
1251                # Add to the list of dependencies if the option exists and isn't empty.
1252                if {[info exists portinfo($deptype)] && $portinfo($deptype) != ""} {
1253                        set depends [concat $depends $portinfo($deptype)]
1254                }
1255        }
1256
1257        set subPorts {}
1258       
1259        foreach depspec $depends {
1260                # grab the portname portion of the depspec
1261                set dep_portname [lindex [split $depspec :] end]
1262               
1263                # Find the porturl
1264                if {[catch {set res [dportsearch "^$dep_portname\$"]} error]} {
1265                        global errorInfo
1266                        ui_debug "$errorInfo"
1267                        ui_error "Internal error: port search failed: $error"
1268                        return 1
1269                }
1270                foreach {name array} $res {
1271                        array set portinfo $array
1272                        if {[info exists portinfo(porturl)]} {
1273                                set porturl $portinfo(porturl)
1274                                break
1275                        }
1276                }
1277
1278                if {![info exists porturl]} {
1279                        ui_error "Dependency '$dep_portname' not found."
1280                        return 1
1281                }
1282
1283                set options [ditem_key $dport options]
1284                set variations [ditem_key $dport variations]
1285
1286                # Figure out the subport.       
1287                set subport [dportopen $porturl $options $variations]
1288
1289                # Is that dependency satisfied or this port installed?
1290                # If we don't skip or if it is not, add it to the list.
1291                if {!$skipSatisfied || ![_dportispresent $subport $depspec]} {
1292                        # Append the sub-port's provides to the port's requirements list.
1293                        ditem_append_unique $dport requires "[ditem_key $subport provides]"
1294       
1295                        if {$recurseDeps} {
1296                                # Skip the port if it's already in the accumulated list.
1297                                if {[lsearch $accDeps $dep_portname] == -1} {
1298                                        # Add it to the list
1299                                        lappend accDeps $dep_portname
1300                               
1301                                        # We'll recursively iterate on it.
1302                                        lappend subPorts $subport
1303                                }
1304                        }
1305                }
1306        }
1307
1308        # Loop on the subports.
1309        if {$recurseDeps} {
1310                foreach subport $subPorts {
1311                        # Sub ports should be installed (all dependencies must be satisfied).
1312                        set res [dportdepends $subport "" $recurseDeps $skipSatisfied $accDeps]
1313                        if {$res != 0} {
1314                                return $res
1315                        }
1316                }
1317        }
1318       
1319        return 0
1320}
1321
1322# selfupdate procedure
1323proc darwinports::selfupdate {optionslist} {
1324        global darwinports::prefix darwinports::rsync_server darwinports::rsync_dir darwinports::rsync_options
1325        array set options $optionslist
1326
1327        if { [info exists options(ports_force)] && $options(ports_force) == "yes" } {
1328                set use_the_force_luke yes
1329                ui_debug "Forcing a rebuild of the darwinports base system."
1330        } else {
1331                set use_the_force_luke no
1332                ui_debug "Rebuilding the darwinports base system if needed."
1333        }
1334        # syncing ports tree. We expect the user have rsync:// in the sources.conf
1335        if {[catch {dportsync} result]} {
1336                return -code error "Couldnt sync dports tree: $result"
1337        }
1338
1339        set dp_base_path [file join $prefix var/db/dports/sources/rsync.${rsync_server}_${rsync_dir}/]
1340        if {![file exists $dp_base_path]} {
1341                file mkdir $dp_base_path
1342        }
1343        ui_debug "DarwinPorts base dir: $dp_base_path"
1344
1345        # get user of the darwinports system
1346        set user [file attributes [file join $prefix var/db/dports/sources/] -owner]
1347        ui_debug "Setting user: $user"
1348
1349        # get darwinports version
1350        set dp_version_path [file join ${prefix}/etc/ports/ dp_version]
1351        if { [file exists $dp_version_path]} {
1352                set fd [open $dp_version_path r]
1353                gets $fd dp_version_old
1354                close $fd
1355        } else {
1356                set dp_version_old 0
1357        }
1358        ui_msg "DarwinPorts base version $dp_version_old installed"
1359
1360        ui_debug "Updating using rsync"
1361        if { [catch { system "/usr/bin/rsync $rsync_options rsync://${rsync_server}/${rsync_dir} $dp_base_path" } ] } {
1362                return -code error "Error: rsync failed in selfupdate"
1363        }
1364
1365        # get downloaded darwinports version and write the old version back
1366        set fd [open [file join $dp_base_path config/dp_version] r]
1367        gets $fd dp_version_new
1368        close $fd
1369        ui_msg "Downloaded DarwinPorts base version $dp_version_new"
1370
1371        # check if we we need to rebuild base
1372        if {$dp_version_new > $dp_version_old || $use_the_force_luke == "yes"} {
1373                ui_msg "Configuring, Building and Installing new DarwinPorts base"
1374                # check if $prefix/bin/port is writable, if so we go !
1375                # get installation user / group
1376                set owner root
1377                set group admin
1378                if {[file exists [file join $prefix bin/port] ]} {
1379                        # set owner
1380                        set owner [file attributes [file join $prefix bin/port] -owner]
1381                        # set group
1382                        set group [file attributes [file join $prefix bin/port] -group]
1383                }
1384                set p_user [exec /usr/bin/whoami]
1385                if {[file writable ${prefix}/bin/port] || [string equal $p_user $owner] } {
1386                        ui_debug "permissions OK"
1387                } else {
1388                        return -code error "Error: $p_user cannot write to ${prefix}/bin - try using sudo"
1389                }
1390                ui_debug "Setting owner: $owner group: $group"
1391
1392                set dp_tclpackage_path [file join $prefix var/db/dports/ .tclpackage]
1393                if { [file exists $dp_tclpackage_path]} {
1394                        set fd [open $dp_tclpackage_path r]
1395                        gets $fd tclpackage
1396                        close $fd
1397                } else {
1398                        set tclpackage [file join ${prefix} share/darwinports/Tcl]
1399                }
1400                # do the actual installation of new base
1401                ui_debug "Install in: $prefix as $owner : $group - TCL-PACKAGE in $tclpackage"
1402                if { [catch { system "cd $dp_base_path && ./configure --prefix=$prefix --with-install-user=$owner --with-install-group=$group --with-tclpackage=$tclpackage && make && make install" } result] } {
1403                        return -code error "Error installing new DarwinPorts base: $result"
1404                }
1405        } else {
1406                ui_msg "The DarwinPorts installation is not outdated and so was not updated"
1407        }
1408
1409        # set the darwinports system to the right owner
1410        ui_debug "Setting ownership to $user"
1411        if { [catch { exec chown -R $user [file join $prefix var/db/dports/sources/] } result] } {
1412                return -code error "Couldn't change permissions: $result"
1413        }
1414
1415        # set the right version
1416        ui_msg "selfupdate done!"
1417
1418        return 0
1419}
1420
1421proc darwinports::version {} {
1422        global darwinports::prefix darwinports::rsync_server darwinports::rsync_dir
1423       
1424        set dp_version_path [file join $prefix etc/ports/ dp_version]
1425
1426        if [file exists $dp_version_path] {
1427                set fd [open $dp_version_path r]
1428                gets $fd retval
1429                return $retval
1430        } else {
1431                return -1
1432        }
1433}
1434
1435# upgrade procedure
1436proc darwinports::upgrade {pname dspec variationslist optionslist {depscachename ""}} {
1437        array set options $optionslist
1438        array set variations $variationslist
1439        if {![string match "" $depscachename]} {
1440                upvar $depscachename depscache
1441        } 
1442
1443        # set to no-zero is epoch overrides version
1444        set epoch_override 0
1445
1446        # check if pname contains \, if so remove it.
1447        if { [regexp {\\} $pname] } {
1448                set portname [join $pname {\\}]
1449                ui_debug "removing stray ecape-character for $portname"
1450        } else {
1451                set portname $pname
1452        }
1453
1454        # check if the port is in tree
1455        if {[catch {dportsearch ^$pname$} result]} {
1456                global errorInfo
1457                ui_debug "$errorInfo"
1458                ui_error "port search failed: $result"
1459                return 1
1460        }
1461        # argh! port doesnt exist!
1462        if {$result == ""} {
1463                ui_error "No port $portname found."
1464                return 1
1465        }
1466        # fill array with information
1467        array set portinfo [lindex $result 1]
1468
1469        # set version_in_tree
1470        if {![info exists portinfo(version)]} {
1471                ui_error "Invalid port entry for $portname, missing version"
1472                return 1
1473        }
1474        set version_in_tree "$portinfo(version)_$portinfo(revision)"
1475        set epoch_in_tree "$portinfo(epoch)"
1476
1477        # the depflag tells us if we should follow deps (this is for stuff installed outside DP)
1478        # if this is set (not 0) we dont follow the deps
1479        set depflag 0
1480
1481        # set version_installed
1482        set ilist {}
1483        if { [catch {set ilist [registry::installed $portname ""]} result] } {
1484                if {$result == "Registry error: $portname not registered as installed." } {
1485                        ui_debug "$portname is *not* installed by DarwinPorts"
1486                        # open porthandle   
1487                        set porturl $portinfo(porturl)
1488                    if {![info exists porturl]} {
1489                        set porturl file://./   
1490                        }   
1491                        if {[catch {set workername [dportopen $porturl [array get options] ]} result]} {
1492                                        global errorInfo
1493                                        ui_debug "$errorInfo"
1494                                ui_error "Unable to open port: $result"       
1495                                        return 1
1496                    }
1497
1498                        if {![_dportispresent $workername $dspec ] } {
1499                                # port in not installed - install it!
1500                                if {[catch {set result [dportexec $workername install]} result]} {
1501                                        global errorInfo
1502                                        ui_debug "$errorInfo"
1503                                        ui_error "Unable to exec port: $result"
1504                                        return 1
1505                                }
1506                        } else {
1507                                # port installed outside DP
1508                                ui_debug "$portname installed outside the DarwinPorts system"
1509                                set depflag 1
1510                        }
1511
1512                } else {
1513                        ui_error "Checking installed version failed: $result"
1514                        exit 1
1515                }
1516        }
1517        set anyactive 0
1518        set version_installed 0
1519        set epoch_installed 0
1520        if {$ilist == ""} {
1521                # XXX  this sets $version_installed to $version_in_tree even if not installed!!
1522                set version_installed $version_in_tree
1523        } else {
1524                # a port could be installed but not activated
1525                # so, deactivate all and save newest for activation later
1526                set num 0
1527                set variant ""
1528                foreach i $ilist {
1529                        set variant [lindex $i 3]
1530                        set version "[lindex $i 1]_[lindex $i 2]"
1531                        if { [rpm-vercomp $version $version_installed] > 0} {
1532                                set version_installed $version
1533                                set epoch_installed [registry::property_retrieve [registry::open_entry $portname [lindex $i 1] [lindex $i 2] $variant] epoch]
1534                                set num $i
1535                        }
1536
1537                        set isactive [lindex $i 4]
1538                        if {$isactive == 1 && [rpm-vercomp $version_installed $version] < 0 } {
1539                                # deactivate version
1540                        if {[catch {portimage::deactivate $portname $version $optionslist} result]} {
1541                                        global errorInfo
1542                                        ui_debug "$errorInfo"
1543                        ui_error "Deactivating $portname $version_installed failed: $result"
1544                        return 1
1545                        }
1546                        }
1547                }
1548                if { [lindex $num 4] == 0} {
1549                        # activate the latest installed version
1550                        if {[catch {portimage::activate $portname $version_installed$variant $optionslist} result]} {
1551                                global errorInfo
1552                                ui_debug "$errorInfo"
1553                        ui_error "Activating $portname $version_installed failed: $result"
1554                                return 1
1555                        }
1556                }
1557        }
1558
1559        # output version numbers
1560        ui_debug "epoch: in tree: $epoch_in_tree installed: $epoch_installed"
1561        ui_debug "$portname $version_in_tree exists in the ports tree"
1562        ui_debug "$portname $version_installed is installed"
1563
1564        # set the nodeps option 
1565        if {![info exists options(ports_nodeps)]} {
1566                set nodeps no
1567        } else {       
1568                set nodeps yes
1569        }
1570
1571        if {$nodeps == "yes" || $depflag == 1} {
1572                ui_debug "Not following dependencies"
1573                set depflag 0
1574        } else {
1575                # build depends is upgraded
1576                if {[info exists portinfo(depends_build)]} {
1577                        foreach i $portinfo(depends_build) {
1578                                if {![llength [array get depscache $i]]} {
1579                                set d [lindex [split $i :] end]
1580                                        set depscache($i) 1
1581                                        upgrade $d $i $variationslist $optionslist depscache
1582                                } 
1583                        }
1584                }
1585                # library depends is upgraded
1586                if {[info exists portinfo(depends_lib)]} {
1587                        foreach i $portinfo(depends_lib) {
1588                                if {![llength [array get depscache $i]]} {
1589                                set d [lindex [split $i :] end]
1590                                        set depscache($i) 1
1591                                        upgrade $d $i $variationslist $optionslist depscache
1592                                } 
1593                        }
1594                }
1595                # runtime depends is upgraded
1596                if {[info exists portinfo(depends_run)]} {
1597                        foreach i $portinfo(depends_run) {
1598                                if {![llength [array get depscache $i]]} {
1599                                set d [lindex [split $i :] end]
1600                                        set depscache($i) 1
1601                                        upgrade $d $i $variationslist $optionslist depscache
1602                                } 
1603                        }
1604                }
1605        }
1606
1607        # check installed version against version in ports
1608        if { [rpm-vercomp $version_installed $version_in_tree] >= 0 } {
1609                ui_debug "No need to upgrade! $portname $version_installed >= $portname $version_in_tree"
1610                if { $epoch_installed >= $epoch_in_tree } {
1611                        return 0
1612                } else {
1613                        ui_debug "epoch override ... upgrading!"
1614                        set epoch_override 1
1615                }
1616        }
1617
1618        # open porthandle
1619        set porturl $portinfo(porturl)
1620        if {![info exists porturl]} {
1621                set porturl file://./
1622        }
1623
1624        # check if the variants is present in $version_in_tree
1625        set oldvariant $variant
1626        set variant [split $variant +]
1627        ui_debug "variants to install $variant"
1628        if {[info exists portinfo(variants)]} {
1629                set avariants $portinfo(variants)
1630        } else {
1631                set avariants {}
1632        }
1633        ui_debug "available variants are : $avariants"
1634        foreach v $variant {
1635                if {[lsearch $avariants $v] == -1} {
1636                } else {
1637                        ui_debug "variant $v is present in $portname $version_in_tree"
1638                        set variations($v) "+"
1639                }
1640        }
1641        ui_debug "new portvariants: [array get variations]"
1642       
1643        if {[catch {set workername [dportopen $porturl [array get options] [array get variations]]} result]} {
1644                global errorInfo
1645                ui_debug "$errorInfo"
1646                ui_error "Unable to open port: $result"
1647                return 1
1648        }
1649
1650        # install version_in_tree
1651        if {[catch {set result [dportexec $workername destroot]} result] || $result != 0} {
1652                global errorInfo
1653                ui_debug "$errorInfo"
1654                ui_error "Unable to upgrade port: $result"
1655                return 1
1656        }
1657
1658        # uninstall old ports
1659        if {[info exists options(port_uninstall_old)] || $epoch_override == 1} {
1660                # uninstalll old
1661                ui_debug "Uninstalling $portname $version_installed$oldvariant"
1662                if {[catch {portuninstall::uninstall $portname $version_installed$oldvariant $optionslist} result]} {
1663                        global errorInfo
1664                        ui_debug "$errorInfo"
1665                ui_error "Uninstall $portname $version_installed$oldvariant failed: $result"
1666                return 1
1667        }
1668        } else {
1669                # XXX deactivate version_installed
1670                if {[catch {portimage::deactivate $portname $version_installed$oldvariant $optionslist} result]} {
1671                        global errorInfo
1672                        ui_debug "$errorInfo"
1673                        ui_error "Deactivating $portname $version_installed failed: $result"
1674                        return 1
1675                }
1676        }
1677
1678        if {[catch {set result [dportexec $workername install]} result]} {
1679                global errorInfo
1680                ui_debug "$errorInfo"
1681                ui_error "Couldn't activate $portname $version_in_tree$oldvariant: $result"
1682                return 1
1683        }
1684       
1685        # close the port handle
1686        dportclose $workername
1687}
Note: See TracBrowser for help on using the repository browser.