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

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

Merge to HEAD changes between tags release_1_2-bp and release_1_2_0 on
release_1_2 branch. This should incorporate all changes that were made
on the 1.2 branch between the time it branched from HEAD, and the time
1.2 was tagged.

  • Property svn:eol-style set to native
File size: 52.6 KB
Line 
1# darwinports.tcl
2# $Id: darwinports.tcl,v 1.200 2005/12/14 05:10:19 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 TMP TMPDIR USER GROUP
433                          http_proxy https_proxy ftp_proxy all_proxy no_proxy
434        }
435    if {[info exists extra_env]} {
436        lappend keepenvkeys ${extra_env}
437    }
438
439        foreach envkey [array names env] {
440                if {[lsearch $keepenvkeys $envkey] == -1} {
441                        array unset env $envkey
442                }
443        }
444
445        if {![info exists xcodeversion] || ![info exists xcodebuildcmd]} {
446                # We'll resolve these later (if needed)
447                trace add variable darwinports::xcodeversion read darwinports::setxcodeinfo
448                trace add variable darwinports::xcodebuildcmd read darwinports::setxcodeinfo
449        }
450
451    # Set the default umask
452    if {![info exists destroot_umask]} {
453        set destroot_umask 022
454    }
455
456    if {[info exists master_site_local] && ![info exists env(MASTER_SITE_LOCAL)]} {
457        set env(MASTER_SITE_LOCAL) "$master_site_local"
458    }
459
460        # Prebinding. useful with MacOS X's ld, harmless elsewhere.
461        # With both variables, prebinding will always succeed but we might need
462        # to redo it.
463    if {![info exists env(LD_PREBIND)] && ![info exists env(LD_PREBIND_ALLOW_OVERLAP)]} {
464        set env(LD_PREBIND) "1"
465        set env(LD_PREBIND_ALLOW_OVERLAP) "1"
466    }
467
468    if {[file isdirectory $libpath]} {
469                lappend auto_path $libpath
470                set darwinports::auto_path $auto_path
471
472                # XXX: not sure if this the best place, but it needs to happen
473                # early, and after auto_path has been set.  Or maybe Pextlib
474                # should ship with darwinports1.0 API?
475                package require Pextlib 1.0
476                package require registry 1.0
477    } else {
478                return -code error "Library directory '$libpath' must exist"
479    }
480}
481
482proc darwinports::worker_init {workername portpath portbuildpath options variations} {
483    global darwinports::portinterp_options darwinports::portinterp_deferred_options registry.installtype
484
485        # Tell the sub interpreter about all the Tcl packages we already
486        # know about so it won't glob for packages.
487        foreach pkgName [package names] {
488                foreach pkgVers [package versions $pkgName] {
489                        set pkgLoadScript [package ifneeded $pkgName $pkgVers]
490                        $workername eval "package ifneeded $pkgName $pkgVers {$pkgLoadScript}"
491                }
492        }
493
494    # Create package require abstraction procedure
495    $workername eval "proc PortSystem \{version\} \{ \n\
496                        package require port \$version \}"
497
498    # Clearly separate slave interpreters and the master interpreter.
499        $workername alias dport_exec dportexec
500        $workername alias dport_open dportopen
501        $workername alias dport_close dportclose
502        $workername alias dport_search dportsearch
503
504    # instantiate the UI call-backs
505        foreach priority ${darwinports::ui_priorities} {
506                $workername alias ui_$priority ui_$priority
507        }
508        $workername alias ui_prefix ui_prefix
509        $workername alias ui_channels ui_channels
510   
511    # Export some utility functions defined here.
512    $workername alias darwinports_create_thread darwinports::create_thread
513
514        # New Registry/Receipts stuff
515        $workername alias registry_new registry::new_entry
516        $workername alias registry_open registry::open_entry
517        $workername alias registry_write registry::write_entry
518        $workername alias registry_prop_store registry::property_store
519        $workername alias registry_prop_retr registry::property_retrieve
520        $workername alias registry_delete registry::delete_entry
521        $workername alias registry_exists registry::entry_exists
522        $workername alias registry_activate portimage::activate
523        $workername alias registry_deactivate portimage::deactivate
524        $workername alias registry_register_deps registry::register_dependencies
525        $workername alias registry_fileinfo_for_index registry::fileinfo_for_index
526        $workername alias registry_bulk_register_files registry::register_bulk_files
527        $workername alias registry_installed registry::installed
528
529        # deferred options processing.
530        $workername alias getoption darwinports::getoption
531
532    foreach opt $portinterp_options {
533                if {![info exists $opt]} {
534                    global darwinports::$opt
535                }
536        if {[info exists $opt]} {
537            $workername eval set system_options($opt) \"[set $opt]\"
538            $workername eval set $opt \"[set $opt]\"
539        }
540    }
541   
542        foreach opt $portinterp_deferred_options {
543                global darwinports::$opt
544                # define the trace hook.
545                $workername eval \
546                        "proc trace_$opt {name1 name2 op} { \n\
547                                trace remove variable ::$opt read ::trace_$opt \n\
548                                global $opt \n\
549                                set $opt \[getoption $opt\] \n\
550                        }"
551                # next access will actually define the variable.
552                $workername eval "trace add variable ::$opt read ::trace_$opt"
553                # define some value now
554                $workername eval set $opt "?"
555        }               
556
557    foreach {opt val} $options {
558        $workername eval set user_options($opt) $val
559        $workername eval set $opt $val
560    }
561
562    foreach {var val} $variations {
563        $workername eval set variations($var) $val
564    }
565
566    if { [info exists registry.installtype] } {
567            $workername eval set installtype ${registry.installtype}
568    }
569}
570
571# Create a thread with most configuration options set.
572# The newly created thread is sent portinterp_options vars and knows where to
573# find all packages we know.
574proc darwinports::create_thread {} {
575    package require Thread
576
577    global darwinports::portinterp_options
578
579        # Create the thread.
580        set result [thread::create -preserved {thread::wait}]
581
582        # Tell the thread about all the Tcl packages we already
583        # know about so it won't glob for packages.
584        foreach pkgName [package names] {
585                foreach pkgVers [package versions $pkgName] {
586                        set pkgLoadScript [package ifneeded $pkgName $pkgVers]
587                        thread::send -async $result "package ifneeded $pkgName $pkgVers {$pkgLoadScript}"
588                }
589        }
590
591        # inherit configuration variables.
592        thread::send -async $result "namespace eval darwinports {}"
593        foreach opt $portinterp_options {
594                if {![info exists $opt]} {
595                        global darwinports::$opt
596                }
597        if {[info exists $opt]} {
598                        thread::send -async $result "global darwinports::$opt"
599                        set val [set darwinports::$opt]
600                        thread::send -async $result "set darwinports::$opt \"$val\""
601                }
602        }
603       
604        return $result
605}
606
607proc darwinports::fetch_port {url} {
608    global darwinports::portdbpath tcl_platform
609    set fetchdir [file join $portdbpath portdirs]
610    set fetchfile [file tail $url]
611    if {[catch {file mkdir $fetchdir} result]} {
612        return -code error $result
613    }
614    if {![file writable $fetchdir]} {
615        return -code error "Port remote fetch failed: You do not have permission to write to $fetchdir"
616    }
617    if {[catch {exec curl -L -s -S -o [file join $fetchdir $fetchfile] $url} result]} {
618        return -code error "Port remote fetch failed: $result"
619    }
620    if {[catch {cd $fetchdir} result]} {
621        return -code error $result
622    }
623    if {[catch {exec tar -zxf $fetchfile} result]} {
624        return -code error "Port extract failed: $result"
625    }
626    if {[regexp {(.+).tgz} $fetchfile match portdir] != 1} {
627        return -code error "Can't decipher portdir from $fetchfile"
628    }
629    return [file join $fetchdir $portdir]
630}
631
632proc darwinports::getprotocol {url} {
633    if {[regexp {(?x)([^:]+)://.+} $url match protocol] == 1} {
634        return ${protocol}
635    } else {
636        return -code error "Can't parse url $url"
637    }
638}
639
640# XXX: this really needs to be rethought in light of the remote index
641# I've added the destdir parameter.  This is the location a remotely
642# fetched port will be downloaded to (currently only applies to
643# dports:// sources).
644proc darwinports::getportdir {url {destdir "."}} {
645        if {[regexp {(?x)([^:]+)://(.+)} $url match protocol string] == 1} {
646                switch -regexp -- ${protocol} {
647                        {^file$} {
648                                return $string
649                        }
650                        {^dports$} {
651                                return [darwinports::index::fetch_port $url $destdir]
652                        }
653                        {^https?$|^ftp$} {
654                                return [darwinports::fetch_port $url]
655                        }
656                        default {
657                                return -code error "Unsupported protocol $protocol"
658                        }
659                }
660        } else {
661                return -code error "Can't parse url $url"
662        }
663}
664
665# dportopen
666# Opens a DarwinPorts portfile specified by a URL.  The portfile is
667# opened with the given list of options and variations.  The result
668# of this function should be treated as an opaque handle to a
669# DarwinPorts Portfile.
670
671proc dportopen {porturl {options ""} {variations ""} {nocache ""}} {
672    global darwinports::portdbpath darwinports::portconf darwinports::open_dports auto_path
673
674        # Look for an already-open DPort with the same URL.
675        # XXX: should compare options and variations here too.
676        # if found, return the existing reference and bump the refcount.
677        if {$nocache != ""} {
678                set dport {}
679        } else {
680                set dport [dlist_search $darwinports::open_dports porturl $porturl]
681        }
682        if {$dport != {}} {
683                set refcnt [ditem_key $dport refcnt]
684                incr refcnt
685                ditem_key $dport refcnt $refcnt
686                return $dport
687        }
688
689        array set options_array $options
690        if {[info exists options_array(portdir)]} {
691                set portdir $options_array(portdir)
692        } else {
693                set portdir ""
694        }
695
696        set portdir [darwinports::getportdir $porturl $portdir]
697        ui_debug "Changing to port directory: $portdir"
698        cd $portdir
699        set portpath [pwd]
700        set workername [interp create]
701
702        set dport [ditem_create]
703        lappend darwinports::open_dports $dport
704        ditem_key $dport porturl $porturl
705        ditem_key $dport portpath $portpath
706        ditem_key $dport workername $workername
707        ditem_key $dport options $options
708        ditem_key $dport variations $variations
709        ditem_key $dport refcnt 1
710
711    darwinports::worker_init $workername $portpath [darwinports::getportbuildpath $portpath] $options $variations
712    if {![file isfile Portfile]} {
713        return -code error "Could not find Portfile in $portdir"
714    }
715
716    $workername eval source Portfile
717       
718    ditem_key $dport provides [$workername eval return \$portname]
719
720    return $dport
721}
722
723# Traverse a directory with ports, calling a function on the path of ports
724# (at the second depth).
725# I.e. the structure of dir shall be:
726# category/port/
727# with a Portfile file in category/port/
728#
729# func:         function to call on every port directory (it is passed
730#                       category/port/ as its parameter)
731# root:         the directory with all the categories directories.
732proc dporttraverse {func {root .}} {
733        # Save the current directory
734        set pwd [pwd]
735       
736        # Join the root.
737        set pathToRoot [file join $pwd $root]
738
739        # Go to root because some callers expects us to be there.
740        cd $pathToRoot
741
742    foreach category [lsort -increasing -unique [readdir $root]] {
743        set pathToCategory [file join $root $category]
744        if {[file isdirectory $pathToCategory]} {
745                # Iterate on port directories.
746                        foreach port [lsort -increasing -unique [readdir $pathToCategory]] {
747                                set pathToPort [file join $pathToCategory $port]
748                                if {[file isdirectory $pathToPort] &&
749                                        [file exists [file join $pathToPort "Portfile"]]} {
750                                        # Call the function.
751                                        $func [file join $category $port]
752                                       
753                                        # Restore the current directory because some
754                                        # functions changes it.
755                                        cd $pathToRoot
756                                }
757                        }
758        }
759        }
760       
761        # Restore the current directory.
762        cd $pwd
763}
764
765### _dportsearchpath is private; subject to change without notice
766
767# depregex -> regex on the filename to find.
768# search_path -> directories to search
769# executable -> whether we want to check that the file is executable by current
770#                               user or not.
771proc _dportsearchpath {depregex search_path {executable 0}} {
772    set found 0
773    foreach path $search_path {
774        if {![file isdirectory $path]} {
775            continue
776        }
777
778        if {[catch {set filelist [readdir $path]} result]} {
779                return -code error "$result ($path)"
780                set filelist ""
781        }
782
783        foreach filename $filelist {
784            if {[regexp $depregex $filename] &&
785                (($executable == 0) || [file executable [file join $path $filename]])} {
786                ui_debug "Found Dependency: path: $path filename: $filename regex: $depregex"
787                set found 1
788                break
789            }
790        }
791    }
792    return $found
793}
794
795### _libtest is private; subject to change without notice
796# XXX - Architecture specific
797# XXX - Rely on information from internal defines in cctools/dyld:
798# define DEFAULT_FALLBACK_FRAMEWORK_PATH
799# /Library/Frameworks:/Library/Frameworks:/Network/Library/Frameworks:/System/Library/Frameworks
800# define DEFAULT_FALLBACK_LIBRARY_PATH /lib:/usr/local/lib:/lib:/usr/lib
801#   -- Since /usr/local is bad, using /lib:/usr/lib only.
802# Environment variables DYLD_FRAMEWORK_PATH, DYLD_LIBRARY_PATH,
803# DYLD_FALLBACK_FRAMEWORK_PATH, and DYLD_FALLBACK_LIBRARY_PATH take precedence
804
805proc _libtest {dport depspec} {
806    global env tcl_platform
807        set depline [lindex [split $depspec :] 1]
808        set prefix [_dportkey $dport prefix]
809       
810        if {[info exists env(DYLD_FRAMEWORK_PATH)]} {
811            lappend search_path $env(DYLD_FRAMEWORK_PATH)
812        } else {
813            lappend search_path /Library/Frameworks /Network/Library/Frameworks /System/Library/Frameworks
814        }
815        if {[info exists env(DYLD_FALLBACK_FRAMEWORK_PATH)]} {
816            lappend search_path $env(DYLD_FALLBACK_FRAMEWORK_PATH)
817        }
818        if {[info exists env(DYLD_LIBRARY_PATH)]} {
819            lappend search_path $env(DYLD_LIBRARY_PATH)
820        }
821        lappend search_path /lib /usr/lib /usr/X11R6/lib ${prefix}/lib
822        if {[info exists env(DYLD_FALLBACK_LIBRARY_PATH)]} {
823            lappend search_path $env(DYLD_FALLBACK_LIBRARY_PATH)
824        }
825
826        set i [string first . $depline]
827        if {$i < 0} {set i [string length $depline]}
828        set depname [string range $depline 0 [expr $i - 1]]
829        set depversion [string range $depline $i end]
830        regsub {\.} $depversion {\.} depversion
831        if {$tcl_platform(os) == "Darwin"} {
832                set depregex \^${depname}${depversion}\\.dylib\$
833        } else {
834                set depregex \^${depname}\\.so${depversion}\$
835        }
836
837        return [_dportsearchpath $depregex $search_path]
838}
839
840### _bintest is private; subject to change without notice
841
842proc _bintest {dport depspec} {
843    global env
844        set depregex [lindex [split $depspec :] 1]
845        set prefix [_dportkey $dport prefix] 
846       
847        set search_path [split $env(PATH) :]
848       
849        set depregex \^$depregex\$
850       
851        return [_dportsearchpath $depregex $search_path 1]
852}
853
854### _pathtest is private; subject to change without notice
855
856proc _pathtest {dport depspec} {
857    global env
858        set depregex [lindex [split $depspec :] 1]
859        set prefix [_dportkey $dport prefix] 
860   
861        # separate directory from regex
862        set fullname $depregex
863
864        regexp {^(.*)/(.*?)$} "$fullname" match search_path depregex
865
866        if {[string index $search_path 0] != "/"} {
867                # Prepend prefix if not an absolute path
868                set search_path "${prefix}/${search_path}"
869        }
870
871        set depregex \^$depregex\$
872
873        return [_dportsearchpath $depregex $search_path]
874}
875
876### _porttest is private; subject to change without notice
877
878proc _porttest {dport depspec} {
879        # We don't actually look for the port, but just return false
880        # in order to let the dportdepends handle the dependency
881        return 0
882}
883
884### _dportinstalled is private; may change without notice
885
886# Determine if a port is already *installed*, as in "in the registry".
887proc _dportinstalled {dport} {
888        # Check for the presense of the port in the registry
889        set workername [ditem_key $dport workername]
890        set res [$workername eval registry_exists \${portname} \${portversion}]
891        if {$res != 0} {
892                ui_debug "[ditem_key $dport provides] is installed"
893                return 1
894        } else {
895                return 0
896        }
897}
898
899### _dportispresent is private; may change without notice
900
901# Determine if some depspec is satisfied or if the given port is installed.
902# We actually start with the registry (faster?)
903#
904# dport         the port to test (to figure out if it's present)
905# depspec       the dependency test specification (path, bin, lib, etc.)
906proc _dportispresent {dport depspec} {
907        # Check for the presense of the port in the registry
908        set workername [ditem_key $dport workername]
909        ui_debug "Searching for dependency: [ditem_key $dport provides]"
910        if {[catch {set reslist [$workername eval registry_installed \${portname}]} res]} {
911                set res 0
912        } else {
913                set res [llength $reslist]
914        }
915        if {$res != 0} {
916                ui_debug "Found Dependency: receipt exists for [ditem_key $dport provides]"
917                return 1
918        } else {
919                # The receipt test failed, use one of the depspec regex mechanisms
920                ui_debug "Didn't find receipt, going to depspec regex for: [ditem_key $dport provides]"
921                set type [lindex [split $depspec :] 0]
922                switch $type {
923                        lib { return [_libtest $dport $depspec] }
924                        bin { return [_bintest $dport $depspec] }
925                        path { return [_pathtest $dport $depspec] }
926                        port { return [_porttest $dport $depspec] }
927                        default {return -code error "unknown depspec type: $type"}
928                }
929                return 0
930        }
931}
932
933### _dportexec is private; may change without notice
934
935proc _dportexec {target dport} {
936        # xxx: set the work path?
937        set workername [ditem_key $dport workername]
938        if {![catch {$workername eval eval_variants variations $target} result] && $result == 0 &&
939                ![catch {$workername eval eval_targets $target} result] && $result == 0} {
940                # If auto-clean mode, clean-up after dependency install
941                if {[string equal ${darwinports::portautoclean} "yes"]} {
942                        # Make sure we are back in the port path before clean
943                        # otherwise if the current directory had been changed to
944                        # inside the port,  the next port may fail when trying to
945                        # install because [pwd] will return a "no file or directory"
946                        # error since the directory it was in is now gone.
947                        set portpath [ditem_key $dport portpath]
948                        catch {cd $portpath}
949                        $workername eval eval_targets clean
950                }
951                return 0
952        } else {
953                # An error occurred.
954                return 1
955        }
956}
957
958# dportexec
959# Execute the specified target of the given dport.
960
961proc dportexec {dport target} {
962    global darwinports::registry.installtype
963
964        set workername [ditem_key $dport workername]
965
966        # XXX: move this into dportopen?
967        if {[$workername eval eval_variants variations $target] != 0} {
968                return 1
969        }
970       
971        # Before we build the port, we must build its dependencies.
972        # XXX: need a more general way of comparing against targets
973        set dlist {}
974        if {$target == "package"} {
975                ui_warn "package target replaced by pkg target, please use the pkg target in the future."
976                set target "pkg"
977        }
978        if {$target == "configure" || $target == "build"
979                || $target == "destroot" || $target == "install"
980                || $target == "archive"
981                || $target == "pkg" || $target == "mpkg"
982                || $target == "rpmpackage" || $target == "dpkg" } {
983
984                if {[dportdepends $dport $target] != 0} {
985                        return 1
986                }
987               
988                # Select out the dependents along the critical path,
989                # but exclude this dport, we might not be installing it.
990                set dlist [dlist_append_dependents $darwinports::open_dports $dport {}]
991               
992                dlist_delete dlist $dport
993
994                # install them
995                # xxx: as with below, this is ugly.  and deps need to be fixed to
996                # understand Port Images before this can get prettier
997                if { [string equal ${darwinports::registry.installtype} "image"] } {
998                        set result [dlist_eval $dlist _dportinstalled [list _dportexec "activate"]]
999                } else {
1000                        set result [dlist_eval $dlist _dportinstalled [list _dportexec "install"]]
1001                }
1002               
1003                if {$result != {}} {
1004                        set errstring "The following dependencies failed to build:"
1005                        foreach ditem $result {
1006                                append errstring " [ditem_key $ditem provides]"
1007                        }
1008                        ui_error $errstring
1009                        return 1
1010                }
1011               
1012                # Close the dependencies, we're done installing them.
1013                foreach ditem $dlist {
1014                        dportclose $ditem
1015                }
1016        }
1017
1018        # If we're doing an install, check if we should clean after
1019        set clean 0
1020        if {[string equal ${darwinports::portautoclean} "yes"] && [string equal $target "install"] } {
1021                set clean 1
1022        }
1023
1024        # If we're doing image installs, then we should activate after install
1025        # xxx: This isn't pretty
1026        if { [string equal ${darwinports::registry.installtype} "image"] && [string equal $target "install"] } {
1027                set target activate
1028        }
1029       
1030        # Build this port with the specified target
1031        set result [$workername eval eval_targets $target]
1032
1033        # If auto-clean mode and successful install, clean-up after install
1034        if {$result == 0 && $clean == 1} {
1035                # Make sure we are back in the port path, just in case
1036                set portpath [ditem_key $dport portpath]
1037                catch {cd $portpath}
1038                $workername eval eval_targets clean
1039        }
1040
1041        return $result
1042}
1043
1044proc darwinports::getsourcepath {url} {
1045        global darwinports::portdbpath
1046        regsub {://} $url {.} source_path
1047        regsub -all {/} $source_path {_} source_path
1048        return [file join $portdbpath sources $source_path]
1049}
1050
1051proc darwinports::getportbuildpath {id} {
1052        global darwinports::portdbpath
1053        regsub {://} $id {.} port_path
1054        regsub -all {/} $port_path {_} port_path
1055        return [file join $portdbpath build $port_path]
1056}
1057
1058proc darwinports::getindex {source} {
1059        # Special case file:// sources
1060        if {[darwinports::getprotocol $source] == "file"} {
1061                return [file join [darwinports::getportdir $source] PortIndex]
1062        }
1063
1064        return [file join [darwinports::getsourcepath $source] PortIndex]
1065}
1066
1067proc dportsync {args} {
1068        global darwinports::sources darwinports::portdbpath tcl_platform
1069
1070        foreach source $sources {
1071                ui_info "Synchronizing from $source"
1072                switch -regexp -- [darwinports::getprotocol $source] {
1073                        {^file$} {
1074                                continue
1075                        }
1076                        {^dports$} {
1077                                darwinports::index::sync $darwinports::portdbpath $source
1078                        }
1079                        {^rsync$} {
1080                                # Where to, boss?
1081                                set destdir [file dirname [darwinports::getindex $source]]
1082
1083                                if {[catch {file mkdir $destdir} result]} {
1084                                        return -code error $result
1085                                }
1086
1087                                # Keep rsync happy with a trailing slash
1088                                if {[string index $source end] != "/"} {
1089                                        set source "${source}/"
1090                                }
1091
1092                                # Do rsync fetch
1093                                if {[catch {system "rsync -rtzv --delete-after --delete \"$source\" \"$destdir\""}]} {
1094                                        return -code error "sync failed doing rsync"
1095                                }
1096                        }
1097                        {^https?$|^ftp$} {
1098                                set indexfile [darwinports::getindex $source]
1099                                if {[catch {file mkdir [file dirname $indexfile]} result]} {
1100                                        return -code error $result
1101                                }
1102                                exec curl -L -s -S -o $indexfile $source/PortIndex
1103                        }
1104                }
1105        }
1106}
1107
1108proc dportsearch {pattern {case_sensitive yes} {matchstyle regexp} {field name}} {
1109        global darwinports::portdbpath darwinports::sources
1110        set matches [list]
1111        set easy [expr { $field == "name" }]
1112       
1113        set found 0
1114        foreach source $sources {
1115                if {[darwinports::getprotocol $source] == "dports"} {
1116                        array set attrs [list name $pattern]
1117                        set res [darwinports::index::search $darwinports::portdbpath $source [array get attrs]]
1118                        eval lappend matches $res
1119                } else {
1120                        if {[catch {set fd [open [darwinports::getindex $source] r]} result]} {
1121                                ui_warn "Can't open index file for source: $source"
1122                        } else {
1123                                incr found 1
1124                                while {[gets $fd line] >= 0} {
1125                                        set name [lindex $line 0]
1126                                        gets $fd line
1127                                       
1128                                        if {$easy} {
1129                                                set target $name
1130                                        } else {
1131                                                array set portinfo $line
1132                                                if {![info exists portinfo($field)]} continue
1133                                                set target $portinfo($field)
1134                                        }
1135                                       
1136                                        switch $matchstyle {
1137                                                exact   { set matchres [expr 0 == ( {$case_sensitive == "yes"} ? [string compare $pattern $target] : [string compare -nocase $pattern $target] )] }
1138                                                glob    { set matchres [expr {$case_sensitive == "yes"} ? [string match $pattern $target] : [string match -nocase $pattern $target]] }
1139                                                regexp  -
1140                                                default { set matchres [expr {$case_sensitive == "yes"} ? [regexp -- $pattern $target] : [regexp -nocase -- $pattern $target]] }
1141                                        }
1142                                       
1143                                        if {$matchres == 1} {
1144                                                if {$easy} {
1145                                                        array set portinfo $line
1146                                                }
1147                                                switch -regexp -- [darwinports::getprotocol ${source}] {
1148                                                        {^rsync$} {
1149                                                                # Rsync files are local
1150                                                                set source_url "file://[darwinports::getsourcepath $source]"
1151                                                        }
1152                                                        default {
1153                                                                set source_url $source
1154                                                        }
1155                                                }
1156                                                if {[info exists portinfo(portarchive)]} {
1157                                                        set porturl ${source_url}/$portinfo(portarchive)
1158                                                } elseif {[info exists portinfo(portdir)]} {
1159                                                        set porturl ${source_url}/$portinfo(portdir)
1160                                                }
1161                                                if {[info exists porturl]} {
1162                                                        lappend line porturl $porturl
1163                                                        ui_debug "Found port in $porturl"
1164                                                } else {
1165                                                        ui_debug "Found port info: $line"
1166                                                }
1167                                                lappend matches $name
1168                                                lappend matches $line
1169                                        }
1170                                }
1171                                close $fd
1172                        }
1173                }
1174        }
1175        if {!$found} {
1176                return -code error "No index(es) found! Have you synced your source indexes?"
1177        }
1178
1179        return $matches
1180}
1181
1182proc dportinfo {dport} {
1183        set workername [ditem_key $dport workername]
1184    return [$workername eval array get PortInfo]
1185}
1186
1187proc dportclose {dport} {
1188        global darwinports::open_dports
1189        set refcnt [ditem_key $dport refcnt]
1190        incr refcnt -1
1191        ditem_key $dport refcnt $refcnt
1192        if {$refcnt == 0} {
1193                dlist_delete darwinports::open_dports $dport
1194                set workername [ditem_key $dport workername]
1195                interp delete $workername
1196        }
1197}
1198
1199##### Private Depspec API #####
1200# This API should be considered work in progress and subject to change without notice.
1201##### "
1202
1203# _dportkey
1204# - returns a variable from the port's interpreter
1205
1206proc _dportkey {dport key} {
1207        set workername [ditem_key $dport workername]
1208        return [$workername eval "return \$${key}"]
1209}
1210
1211# dportdepends builds the list of dports which the given port depends on.
1212# This list is added to $dport.
1213# This list actually depends on the target.
1214# This method can optionally recurse through the dependencies, looking for
1215#   dependencies of dependencies.
1216# This method can optionally cut the search when ports are already installed or
1217#   the dependencies are satisfied.
1218#
1219# dport -> dport item
1220# target -> target to consider the dependency for
1221# recurseDeps -> if the search should be recursive
1222# skipSatisfied -> cut the search tree when encountering installed/satisfied
1223#                  dependencies ports.
1224# accDeps -> accumulator for recursive calls
1225# return 0 if everything was ok, an non zero integer otherwise.
1226proc dportdepends {dport {target ""} {recurseDeps 1} {skipSatisfied 1} {accDeps {}}} {
1227
1228        array set portinfo [dportinfo $dport]
1229        set depends {}
1230        set deptypes {}
1231       
1232        # Determine deptypes to look for based on target
1233        switch $target {
1234                configure       { set deptypes "depends_lib" }
1235               
1236                build           { set deptypes "depends_lib depends_build" }
1237               
1238                destroot        -
1239                install         -
1240                archive         -
1241                pkg                     -
1242                mpkg            -
1243                rpmpackage      -
1244                dpkg            -
1245                ""                      { set deptypes "depends_lib depends_build depends_run" }
1246        }
1247       
1248        # Gather the dependencies for deptypes
1249        foreach deptype $deptypes {
1250                # Add to the list of dependencies if the option exists and isn't empty.
1251                if {[info exists portinfo($deptype)] && $portinfo($deptype) != ""} {
1252                        set depends [concat $depends $portinfo($deptype)]
1253                }
1254        }
1255
1256        set subPorts {}
1257       
1258        foreach depspec $depends {
1259                # grab the portname portion of the depspec
1260                set dep_portname [lindex [split $depspec :] end]
1261               
1262                # Find the porturl
1263                if {[catch {set res [dportsearch "^$dep_portname\$"]} error]} {
1264                        global errorInfo
1265                        ui_debug "$errorInfo"
1266                        ui_error "Internal error: port search failed: $error"
1267                        return 1
1268                }
1269                foreach {name array} $res {
1270                        array set portinfo $array
1271                        if {[info exists portinfo(porturl)]} {
1272                                set porturl $portinfo(porturl)
1273                                break
1274                        }
1275                }
1276
1277                if {![info exists porturl]} {
1278                        ui_error "Dependency '$dep_portname' not found."
1279                        return 1
1280                }
1281
1282                set options [ditem_key $dport options]
1283                set variations [ditem_key $dport variations]
1284
1285                # Figure out the subport.       
1286                set subport [dportopen $porturl $options $variations]
1287
1288                # Is that dependency satisfied or this port installed?
1289                # If we don't skip or if it is not, add it to the list.
1290                if {!$skipSatisfied || ![_dportispresent $subport $depspec]} {
1291                        # Append the sub-port's provides to the port's requirements list.
1292                        ditem_append_unique $dport requires "[ditem_key $subport provides]"
1293       
1294                        if {$recurseDeps} {
1295                                # Skip the port if it's already in the accumulated list.
1296                                if {[lsearch $accDeps $dep_portname] == -1} {
1297                                        # Add it to the list
1298                                        lappend accDeps $dep_portname
1299                               
1300                                        # We'll recursively iterate on it.
1301                                        lappend subPorts $subport
1302                                }
1303                        }
1304                }
1305        }
1306
1307        # Loop on the subports.
1308        if {$recurseDeps} {
1309                foreach subport $subPorts {
1310                        # Sub ports should be installed (all dependencies must be satisfied).
1311                        set res [dportdepends $subport "" $recurseDeps $skipSatisfied $accDeps]
1312                        if {$res != 0} {
1313                                return $res
1314                        }
1315                }
1316        }
1317       
1318        return 0
1319}
1320
1321# selfupdate procedure
1322proc darwinports::selfupdate {optionslist} {
1323        global darwinports::prefix darwinports::rsync_server darwinports::rsync_dir darwinports::rsync_options
1324        array set options $optionslist
1325
1326        if { [info exists options(ports_force)] && $options(ports_force) == "yes" } {
1327                set use_the_force_luke yes
1328                ui_debug "Forcing a rebuild of the darwinports base system."
1329        } else {
1330                set use_the_force_luke no
1331                ui_debug "Rebuilding the darwinports base system if needed."
1332        }
1333        # syncing ports tree. We expect the user have rsync:// in the sources.conf
1334        if {[catch {dportsync} result]} {
1335                return -code error "Couldnt sync dports tree: $result"
1336        }
1337
1338        set dp_base_path [file join $prefix var/db/dports/sources/rsync.${rsync_server}_${rsync_dir}/]
1339        if {![file exists $dp_base_path]} {
1340                file mkdir $dp_base_path
1341        }
1342        ui_debug "DarwinPorts base dir: $dp_base_path"
1343
1344        # get user of the darwinports system
1345        set user [file attributes [file join $prefix var/db/dports/sources/] -owner]
1346        ui_debug "Setting user: $user"
1347
1348        # get darwinports version
1349        set dp_version_path [file join ${prefix}/etc/ports/ dp_version]
1350        if { [file exists $dp_version_path]} {
1351                set fd [open $dp_version_path r]
1352                gets $fd dp_version_old
1353                close $fd
1354        } else {
1355                set dp_version_old 0
1356        }
1357        ui_msg "DarwinPorts base version $dp_version_old installed"
1358
1359        ui_debug "Updating using rsync"
1360        if { [catch { system "/usr/bin/rsync $rsync_options rsync://${rsync_server}/${rsync_dir} $dp_base_path" } ] } {
1361                return -code error "Error: rsync failed in selfupdate"
1362        }
1363
1364        # get downloaded darwinports version and write the old version back
1365        set fd [open [file join $dp_base_path config/dp_version] r]
1366        gets $fd dp_version_new
1367        close $fd
1368        ui_msg "Downloaded DarwinPorts base version $dp_version_new"
1369
1370        # check if we we need to rebuild base
1371        if {$dp_version_new > $dp_version_old || $use_the_force_luke == "yes"} {
1372                ui_msg "Configuring, Building and Installing new DarwinPorts base"
1373                # check if $prefix/bin/port is writable, if so we go !
1374                # get installation user / group
1375                set owner root
1376                set group admin
1377                if {[file exists [file join $prefix bin/port] ]} {
1378                        # set owner
1379                        set owner [file attributes [file join $prefix bin/port] -owner]
1380                        # set group
1381                        set group [file attributes [file join $prefix bin/port] -group]
1382                }
1383                set p_user [exec /usr/bin/whoami]
1384                if {[file writable ${prefix}/bin/port] || [string equal $p_user $owner] } {
1385                        ui_debug "permissions OK"
1386                } else {
1387                        return -code error "Error: $p_user cannot write to ${prefix}/bin - try using sudo"
1388                }
1389                ui_debug "Setting owner: $owner group: $group"
1390
1391                set dp_tclpackage_path [file join $prefix var/db/dports/ .tclpackage]
1392                if { [file exists $dp_tclpackage_path]} {
1393                        set fd [open $dp_tclpackage_path r]
1394                        gets $fd tclpackage
1395                        close $fd
1396                } else {
1397                        set tclpackage [file join ${prefix} share/darwinports/Tcl]
1398                }
1399                # do the actual installation of new base
1400                ui_debug "Install in: $prefix as $owner : $group - TCL-PACKAGE in $tclpackage"
1401                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] } {
1402                        return -code error "Error installing new DarwinPorts base: $result"
1403                }
1404        } else {
1405                ui_msg "The DarwinPorts installation is not outdated and so was not updated"
1406        }
1407
1408        # set the darwinports system to the right owner
1409        ui_debug "Setting ownership to $user"
1410        if { [catch { exec chown -R $user [file join $prefix var/db/dports/sources/] } result] } {
1411                return -code error "Couldn't change permissions: $result"
1412        }
1413
1414        # set the right version
1415        ui_msg "selfupdate done!"
1416
1417        return 0
1418}
1419
1420proc darwinports::version {} {
1421        global darwinports::prefix darwinports::rsync_server darwinports::rsync_dir
1422       
1423        set dp_version_path [file join $prefix etc/ports/ dp_version]
1424
1425        if [file exists $dp_version_path] {
1426                set fd [open $dp_version_path r]
1427                gets $fd retval
1428                return $retval
1429        } else {
1430                return -1
1431        }
1432}
1433
1434# upgrade procedure
1435proc darwinports::upgrade {pname dspec variationslist optionslist} {
1436        array set options $optionslist
1437        array set variations $variationslist
1438
1439        # set to no-zero is epoch overrides version
1440        set epoch_override 0
1441
1442        # check if pname contains \, if so remove it.
1443        if { [regexp {\\} $pname] } {
1444                set portname [join $pname {\\}]
1445                ui_debug "removing stray ecape-character for $portname"
1446        } else {
1447                set portname $pname
1448        }
1449
1450        # check if the port is in tree
1451        if {[catch {dportsearch ^$pname$} result]} {
1452                global errorInfo
1453                ui_debug "$errorInfo"
1454                ui_error "port search failed: $result"
1455                return 1
1456        }
1457        # argh! port doesnt exist!
1458        if {$result == ""} {
1459                ui_error "No port $portname found."
1460                return 1
1461        }
1462        # fill array with information
1463        array set portinfo [lindex $result 1]
1464
1465        # set version_in_tree
1466        if {![info exists portinfo(version)]} {
1467                ui_error "Invalid port entry for $portname, missing version"
1468                return 1
1469        }
1470        set version_in_tree "$portinfo(version)_$portinfo(revision)"
1471        set epoch_in_tree "$portinfo(epoch)"
1472
1473        # the depflag tells us if we should follow deps (this is for stuff installed outside DP)
1474        # if this is set (not 0) we dont follow the deps
1475        set depflag 0
1476
1477        # set version_installed
1478        set ilist {}
1479        if { [catch {set ilist [registry::installed $portname ""]} result] } {
1480                if {$result == "Registry error: $portname not registered as installed." } {
1481                        ui_debug "$portname is *not* installed by DarwinPorts"
1482                        # open porthandle   
1483                        set porturl $portinfo(porturl)
1484                    if {![info exists porturl]} {
1485                        set porturl file://./   
1486                        }   
1487                        if {[catch {set workername [dportopen $porturl [array get options] ]} result]} {
1488                                        global errorInfo
1489                                        ui_debug "$errorInfo"
1490                                ui_error "Unable to open port: $result"       
1491                                        return 1
1492                    }
1493
1494                        if {![_dportispresent $workername $dspec ] } {
1495                                # port in not installed - install it!
1496                                if {[catch {set result [dportexec $workername install]} result]} {
1497                                        global errorInfo
1498                                        ui_debug "$errorInfo"
1499                                        ui_error "Unable to exec port: $result"
1500                                        return 1
1501                                }
1502                        } else {
1503                                # port installed outside DP
1504                                ui_debug "$portname installed outside the DarwinPorts system"
1505                                set depflag 1
1506                        }
1507
1508                } else {
1509                        ui_error "Checking installed version failed: $result"
1510                        exit 1
1511                }
1512        }
1513        set anyactive 0
1514        set version_installed 0
1515        set epoch_installed 0
1516        if {$ilist == ""} {
1517                # XXX  this sets $version_installed to $version_in_tree even if not installed!!
1518                set version_installed $version_in_tree
1519        } else {
1520                # a port could be installed but not activated
1521                # so, deactivate all and save newest for activation later
1522                set num 0
1523                set variant ""
1524                foreach i $ilist {
1525                        set variant [lindex $i 3]
1526                        set version "[lindex $i 1]_[lindex $i 2]"
1527                        if { [rpm-vercomp $version $version_installed] > 0} {
1528                                set version_installed $version
1529                                set epoch_installed [registry::property_retrieve [registry::open_entry $portname [lindex $i 1] [lindex $i 2] $variant] epoch]
1530                                set num $i
1531                        }
1532
1533                        set isactive [lindex $i 4]
1534                        if {$isactive == 1 && [rpm-vercomp $version_installed $version] < 0 } {
1535                                # deactivate version
1536                        if {[catch {portimage::deactivate $portname $version $optionslist} result]} {
1537                                        global errorInfo
1538                                        ui_debug "$errorInfo"
1539                        ui_error "Deactivating $portname $version_installed failed: $result"
1540                        return 1
1541                        }
1542                        }
1543                }
1544                if { [lindex $num 4] == 0} {
1545                        # activate the latest installed version
1546                        if {[catch {portimage::activate $portname $version_installed$variant $optionslist} result]} {
1547                                global errorInfo
1548                                ui_debug "$errorInfo"
1549                        ui_error "Activating $portname $version_installed failed: $result"
1550                                return 1
1551                        }
1552                }
1553        }
1554
1555        # output version numbers
1556        ui_debug "epoch: in tree: $epoch_in_tree installed: $epoch_installed"
1557        ui_debug "$portname $version_in_tree exists in the ports tree"
1558        ui_debug "$portname $version_installed is installed"
1559
1560        # set the nodeps option 
1561        if {![info exists options(ports_nodeps)]} {
1562                set nodeps no
1563        } else {       
1564                set nodeps yes
1565        }
1566
1567        if {$nodeps == "yes" || $depflag == 1} {
1568                ui_debug "Not following dependencies"
1569                set depflag 0
1570        } else {
1571                # build depends is upgraded
1572                if {[info exists portinfo(depends_build)]} {
1573                        foreach i $portinfo(depends_build) {
1574                                set d [lindex [split $i :] end]
1575                                upgrade $d $i $variationslist $optionslist
1576                        }
1577                }
1578                # library depends is upgraded
1579                if {[info exists portinfo(depends_lib)]} {
1580                        foreach i $portinfo(depends_lib) {
1581                                set d [lindex [split $i :] end]
1582                                upgrade $d $i $variationslist $optionslist
1583                        }
1584                }
1585                # runtime depends is upgraded
1586                if {[info exists portinfo(depends_run)]} {
1587                        foreach i $portinfo(depends_run) {
1588                                set d [lindex [split $i :] end]
1589                                upgrade $d $i $variationslist $optionslist
1590                        }
1591                }
1592        }
1593
1594        # check installed version against version in ports
1595        if { [rpm-vercomp $version_installed $version_in_tree] >= 0 } {
1596                ui_debug "No need to upgrade! $portname $version_installed >= $portname $version_in_tree"
1597                if { $epoch_installed >= $epoch_in_tree } {
1598                        return 0
1599                } else {
1600                        ui_debug "epoch override ... upgrading!"
1601                        set epoch_override 1
1602                }
1603        }
1604
1605        # open porthandle
1606        set porturl $portinfo(porturl)
1607        if {![info exists porturl]} {
1608                set porturl file://./
1609        }
1610
1611        # check if the variants is present in $version_in_tree
1612        set oldvariant $variant
1613        set variant [split $variant +]
1614        ui_debug "variants to install $variant"
1615        if {[info exists portinfo(variants)]} {
1616                set avariants $portinfo(variants)
1617        } else {
1618                set avariants {}
1619        }
1620        ui_debug "available variants are : $avariants"
1621        foreach v $variant {
1622                if {[lsearch $avariants $v] == -1} {
1623                } else {
1624                        ui_debug "variant $v is present in $portname $version_in_tree"
1625                        set variations($v) "+"
1626                }
1627        }
1628        ui_debug "new portvariants: [array get variations]"
1629       
1630        if {[catch {set workername [dportopen $porturl [array get options] [array get variations]]} result]} {
1631                global errorInfo
1632                ui_debug "$errorInfo"
1633                ui_error "Unable to open port: $result"
1634                return 1
1635        }
1636
1637        # install version_in_tree
1638        if {[catch {set result [dportexec $workername destroot]} result] || $result != 0} {
1639                global errorInfo
1640                ui_debug "$errorInfo"
1641                ui_error "Unable to upgrade port: $result"
1642                return 1
1643        }
1644
1645        # uninstall old ports
1646        if {[info exists options(port_uninstall_old)] || $epoch_override == 1} {
1647                # uninstalll old
1648                ui_debug "Uninstalling $portname $version_installed$oldvariant"
1649                if {[catch {portuninstall::uninstall $portname $version_installed$oldvariant $optionslist} result]} {
1650                        global errorInfo
1651                        ui_debug "$errorInfo"
1652                ui_error "Uninstall $portname $version_installed$oldvariant failed: $result"
1653                return 1
1654        }
1655        } else {
1656                # XXX deactivate version_installed
1657                if {[catch {portimage::deactivate $portname $version_installed$oldvariant $optionslist} result]} {
1658                        global errorInfo
1659                        ui_debug "$errorInfo"
1660                        ui_error "Deactivating $portname $version_installed failed: $result"
1661                        return 1
1662                }
1663        }
1664
1665        if {[catch {set result [dportexec $workername install]} result]} {
1666                global errorInfo
1667                ui_debug "$errorInfo"
1668                ui_error "Couldn't activate $portname $version_in_tree$oldvariant: $result"
1669                return 1
1670        }
1671       
1672        # close the port handle
1673        dportclose $workername
1674}
Note: See TracBrowser for help on using the repository browser.