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

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

Fix bug in dportsearch.
Information from previous iterations was sneaking into current when a particular field didn't exist in the current iteration.
Thanks for the report, Joe Auty.

  • Property svn:eol-style set to native
File size: 54.0 KB
Line 
1# darwinports.tcl
2# $Id: darwinports.tcl,v 1.209 2006/03/19 17:25:08 jberry Exp $
3#
4# Copyright (c) 2002 Apple Computer, Inc.
5# Copyright (c) 2004 - 2005 Paul Guyot, <pguyot@kallisys.net>.
6# Copyright (c) 2004 - 2006 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    if {![file isfile Portfile]} {
702        return -code error "Could not find Portfile in $portdir"
703    }
704
705        set workername [interp create]
706
707        set dport [ditem_create]
708        lappend darwinports::open_dports $dport
709        ditem_key $dport porturl $porturl
710        ditem_key $dport portpath $portpath
711        ditem_key $dport workername $workername
712        ditem_key $dport options $options
713        ditem_key $dport variations $variations
714        ditem_key $dport refcnt 1
715       
716    darwinports::worker_init $workername $portpath [darwinports::getportbuildpath $portpath] $options $variations
717
718    $workername eval source Portfile
719
720    ditem_key $dport provides [$workername eval return \$portname]
721
722    return $dport
723}
724
725# Traverse a directory with ports, calling a function on the path of ports
726# (at the second depth).
727# I.e. the structure of dir shall be:
728# category/port/
729# with a Portfile file in category/port/
730#
731# func:         function to call on every port directory (it is passed
732#                       category/port/ as its parameter)
733# root:         the directory with all the categories directories.
734proc dporttraverse {func {root .}} {
735        # Save the current directory
736        set pwd [pwd]
737       
738        # Join the root.
739        set pathToRoot [file join $pwd $root]
740
741        # Go to root because some callers expects us to be there.
742        cd $pathToRoot
743
744    foreach category [lsort -increasing -unique [readdir $root]] {
745        set pathToCategory [file join $root $category]
746        if {[file isdirectory $pathToCategory]} {
747                # Iterate on port directories.
748                        foreach port [lsort -increasing -unique [readdir $pathToCategory]] {
749                                set pathToPort [file join $pathToCategory $port]
750                                if {[file isdirectory $pathToPort] &&
751                                        [file exists [file join $pathToPort "Portfile"]]} {
752                                        # Call the function.
753                                        $func [file join $category $port]
754                                       
755                                        # Restore the current directory because some
756                                        # functions changes it.
757                                        cd $pathToRoot
758                                }
759                        }
760        }
761        }
762       
763        # Restore the current directory.
764        cd $pwd
765}
766
767### _dportsearchpath is private; subject to change without notice
768
769# depregex -> regex on the filename to find.
770# search_path -> directories to search
771# executable -> whether we want to check that the file is executable by current
772#                               user or not.
773proc _dportsearchpath {depregex search_path {executable 0}} {
774    set found 0
775    foreach path $search_path {
776        if {![file isdirectory $path]} {
777            continue
778        }
779
780        if {[catch {set filelist [readdir $path]} result]} {
781                return -code error "$result ($path)"
782                set filelist ""
783        }
784
785        foreach filename $filelist {
786            if {[regexp $depregex $filename] &&
787                (($executable == 0) || [file executable [file join $path $filename]])} {
788                ui_debug "Found Dependency: path: $path filename: $filename regex: $depregex"
789                set found 1
790                break
791            }
792        }
793    }
794    return $found
795}
796
797### _libtest is private; subject to change without notice
798# XXX - Architecture specific
799# XXX - Rely on information from internal defines in cctools/dyld:
800# define DEFAULT_FALLBACK_FRAMEWORK_PATH
801# /Library/Frameworks:/Library/Frameworks:/Network/Library/Frameworks:/System/Library/Frameworks
802# define DEFAULT_FALLBACK_LIBRARY_PATH /lib:/usr/local/lib:/lib:/usr/lib
803#   -- Since /usr/local is bad, using /lib:/usr/lib only.
804# Environment variables DYLD_FRAMEWORK_PATH, DYLD_LIBRARY_PATH,
805# DYLD_FALLBACK_FRAMEWORK_PATH, and DYLD_FALLBACK_LIBRARY_PATH take precedence
806
807proc _libtest {dport depspec} {
808    global env tcl_platform
809        set depline [lindex [split $depspec :] 1]
810        set prefix [_dportkey $dport prefix]
811       
812        if {[info exists env(DYLD_FRAMEWORK_PATH)]} {
813            lappend search_path $env(DYLD_FRAMEWORK_PATH)
814        } else {
815            lappend search_path /Library/Frameworks /Network/Library/Frameworks /System/Library/Frameworks
816        }
817        if {[info exists env(DYLD_FALLBACK_FRAMEWORK_PATH)]} {
818            lappend search_path $env(DYLD_FALLBACK_FRAMEWORK_PATH)
819        }
820        if {[info exists env(DYLD_LIBRARY_PATH)]} {
821            lappend search_path $env(DYLD_LIBRARY_PATH)
822        }
823        lappend search_path /lib /usr/lib /usr/X11R6/lib ${prefix}/lib
824        if {[info exists env(DYLD_FALLBACK_LIBRARY_PATH)]} {
825            lappend search_path $env(DYLD_FALLBACK_LIBRARY_PATH)
826        }
827
828        set i [string first . $depline]
829        if {$i < 0} {set i [string length $depline]}
830        set depname [string range $depline 0 [expr $i - 1]]
831        set depversion [string range $depline $i end]
832        regsub {\.} $depversion {\.} depversion
833        if {$tcl_platform(os) == "Darwin"} {
834                set depregex \^${depname}${depversion}\\.dylib\$
835        } else {
836                set depregex \^${depname}\\.so${depversion}\$
837        }
838
839        return [_dportsearchpath $depregex $search_path]
840}
841
842### _bintest is private; subject to change without notice
843
844proc _bintest {dport depspec} {
845    global env
846        set depregex [lindex [split $depspec :] 1]
847        set prefix [_dportkey $dport prefix] 
848       
849        set search_path [split $env(PATH) :]
850       
851        set depregex \^$depregex\$
852       
853        return [_dportsearchpath $depregex $search_path 1]
854}
855
856### _pathtest is private; subject to change without notice
857
858proc _pathtest {dport depspec} {
859    global env
860        set depregex [lindex [split $depspec :] 1]
861        set prefix [_dportkey $dport prefix] 
862   
863        # separate directory from regex
864        set fullname $depregex
865
866        regexp {^(.*)/(.*?)$} "$fullname" match search_path depregex
867
868        if {[string index $search_path 0] != "/"} {
869                # Prepend prefix if not an absolute path
870                set search_path "${prefix}/${search_path}"
871        }
872
873        set depregex \^$depregex\$
874
875        return [_dportsearchpath $depregex $search_path]
876}
877
878### _porttest is private; subject to change without notice
879
880proc _porttest {dport depspec} {
881        # We don't actually look for the port, but just return false
882        # in order to let the dportdepends handle the dependency
883        return 0
884}
885
886### _dportinstalled is private; may change without notice
887
888# Determine if a port is already *installed*, as in "in the registry".
889proc _dportinstalled {dport} {
890        # Check for the presense of the port in the registry
891        set workername [ditem_key $dport workername]
892        set res [$workername eval registry_exists \${portname} \${portversion}]
893        if {$res != 0} {
894                ui_debug "[ditem_key $dport provides] is installed"
895                return 1
896        } else {
897                return 0
898        }
899}
900
901### _dportispresent is private; may change without notice
902
903# Determine if some depspec is satisfied or if the given port is installed.
904# We actually start with the registry (faster?)
905#
906# dport         the port to test (to figure out if it's present)
907# depspec       the dependency test specification (path, bin, lib, etc.)
908proc _dportispresent {dport depspec} {
909        # Check for the presense of the port in the registry
910        set workername [ditem_key $dport workername]
911        ui_debug "Searching for dependency: [ditem_key $dport provides]"
912        if {[catch {set reslist [$workername eval registry_installed \${portname}]} res]} {
913                set res 0
914        } else {
915                set res [llength $reslist]
916        }
917        if {$res != 0} {
918                ui_debug "Found Dependency: receipt exists for [ditem_key $dport provides]"
919                return 1
920        } else {
921                # The receipt test failed, use one of the depspec regex mechanisms
922                ui_debug "Didn't find receipt, going to depspec regex for: [ditem_key $dport provides]"
923                set type [lindex [split $depspec :] 0]
924                switch $type {
925                        lib { return [_libtest $dport $depspec] }
926                        bin { return [_bintest $dport $depspec] }
927                        path { return [_pathtest $dport $depspec] }
928                        port { return [_porttest $dport $depspec] }
929                        default {return -code error "unknown depspec type: $type"}
930                }
931                return 0
932        }
933}
934
935### _dportexec is private; may change without notice
936
937proc _dportexec {target dport} {
938        # xxx: set the work path?
939        set workername [ditem_key $dport workername]
940        if {![catch {$workername eval eval_variants variations $target} result] && $result == 0 &&
941                ![catch {$workername eval eval_targets $target} result] && $result == 0} {
942                # If auto-clean mode, clean-up after dependency install
943                if {[string equal ${darwinports::portautoclean} "yes"]} {
944                        # Make sure we are back in the port path before clean
945                        # otherwise if the current directory had been changed to
946                        # inside the port,  the next port may fail when trying to
947                        # install because [pwd] will return a "no file or directory"
948                        # error since the directory it was in is now gone.
949                        set portpath [ditem_key $dport portpath]
950                        catch {cd $portpath}
951                        $workername eval eval_targets clean
952                }
953                return 0
954        } else {
955                # An error occurred.
956                return 1
957        }
958}
959
960# dportexec
961# Execute the specified target of the given dport.
962
963proc dportexec {dport target} {
964    global darwinports::registry.installtype
965
966        set workername [ditem_key $dport workername]
967
968        # XXX: move this into dportopen?
969        if {[$workername eval eval_variants variations $target] != 0} {
970                return 1
971        }
972       
973        # Before we build the port, we must build its dependencies.
974        # XXX: need a more general way of comparing against targets
975        set dlist {}
976        if {$target == "package"} {
977                ui_warn "package target replaced by pkg target, please use the pkg target in the future."
978                set target "pkg"
979        }
980        if {$target == "configure" || $target == "build"
981                || $target == "destroot" || $target == "install"
982                || $target == "archive"
983                || $target == "pkg" || $target == "mpkg"
984                || $target == "rpmpackage" || $target == "dpkg" } {
985
986                if {[dportdepends $dport $target] != 0} {
987                        return 1
988                }
989               
990                # Select out the dependents along the critical path,
991                # but exclude this dport, we might not be installing it.
992                set dlist [dlist_append_dependents $darwinports::open_dports $dport {}]
993               
994                dlist_delete dlist $dport
995
996                # install them
997                # xxx: as with below, this is ugly.  and deps need to be fixed to
998                # understand Port Images before this can get prettier
999                if { [string equal ${darwinports::registry.installtype} "image"] } {
1000                        set result [dlist_eval $dlist _dportinstalled [list _dportexec "activate"]]
1001                } else {
1002                        set result [dlist_eval $dlist _dportinstalled [list _dportexec "install"]]
1003                }
1004               
1005                if {$result != {}} {
1006                        set errstring "The following dependencies failed to build:"
1007                        foreach ditem $result {
1008                                append errstring " [ditem_key $ditem provides]"
1009                        }
1010                        ui_error $errstring
1011                        return 1
1012                }
1013               
1014                # Close the dependencies, we're done installing them.
1015                foreach ditem $dlist {
1016                        dportclose $ditem
1017                }
1018        }
1019
1020        # If we're doing an install, check if we should clean after
1021        set clean 0
1022        if {[string equal ${darwinports::portautoclean} "yes"] && [string equal $target "install"] } {
1023                set clean 1
1024        }
1025
1026        # If we're doing image installs, then we should activate after install
1027        # xxx: This isn't pretty
1028        if { [string equal ${darwinports::registry.installtype} "image"] && [string equal $target "install"] } {
1029                set target activate
1030        }
1031       
1032        # Build this port with the specified target
1033        set result [$workername eval eval_targets $target]
1034
1035        # If auto-clean mode and successful install, clean-up after install
1036        if {$result == 0 && $clean == 1} {
1037                # Make sure we are back in the port path, just in case
1038                set portpath [ditem_key $dport portpath]
1039                catch {cd $portpath}
1040                $workername eval eval_targets clean
1041        }
1042
1043        return $result
1044}
1045
1046proc darwinports::getsourcepath {url} {
1047        global darwinports::portdbpath
1048        regsub {://} $url {.} source_path
1049        regsub -all {/} $source_path {_} source_path
1050        return [file join $portdbpath sources $source_path]
1051}
1052
1053proc darwinports::getportbuildpath {id} {
1054        global darwinports::portdbpath
1055        regsub {://} $id {.} port_path
1056        regsub -all {/} $port_path {_} port_path
1057        return [file join $portdbpath build $port_path]
1058}
1059
1060proc darwinports::getindex {source} {
1061        # Special case file:// sources
1062        if {[darwinports::getprotocol $source] == "file"} {
1063                return [file join [darwinports::getportdir $source] PortIndex]
1064        }
1065
1066        return [file join [darwinports::getsourcepath $source] PortIndex]
1067}
1068
1069proc dportsync {args} {
1070        global darwinports::sources darwinports::portdbpath tcl_platform
1071
1072        foreach source $sources {
1073                ui_info "Synchronizing from $source"
1074                switch -regexp -- [darwinports::getprotocol $source] {
1075                        {^file$} {
1076                                continue
1077                        }
1078                        {^dports$} {
1079                                darwinports::index::sync $darwinports::portdbpath $source
1080                        }
1081                        {^rsync$} {
1082                                # Where to, boss?
1083                                set destdir [file dirname [darwinports::getindex $source]]
1084
1085                                if {[catch {file mkdir $destdir} result]} {
1086                                        return -code error $result
1087                                }
1088
1089                                # Keep rsync happy with a trailing slash
1090                                if {[string index $source end] != "/"} {
1091                                        set source "${source}/"
1092                                }
1093
1094                                # Do rsync fetch
1095                                if {[catch {system "rsync -rtzv --delete-after --delete \"$source\" \"$destdir\""}]} {
1096                                        return -code error "sync failed doing rsync"
1097                                }
1098                        }
1099                        {^https?$|^ftp$} {
1100                                set indexfile [darwinports::getindex $source]
1101                                if {[catch {file mkdir [file dirname $indexfile]} result]} {
1102                                        return -code error $result
1103                                }
1104                                exec curl -L -s -S -o $indexfile $source/PortIndex
1105                        }
1106                }
1107        }
1108}
1109
1110proc dportsearch {pattern {case_sensitive yes} {matchstyle regexp} {field name}} {
1111        global darwinports::portdbpath darwinports::sources
1112        set matches [list]
1113        set easy [expr { $field == "name" }]
1114       
1115        set found 0
1116        foreach source $sources {
1117                if {[darwinports::getprotocol $source] == "dports"} {
1118                        array set attrs [list name $pattern]
1119                        set res [darwinports::index::search $darwinports::portdbpath $source [array get attrs]]
1120                        eval lappend matches $res
1121                } else {
1122                        if {[catch {set fd [open [darwinports::getindex $source] r]} result]} {
1123                                ui_warn "Can't open index file for source: $source"
1124                        } else {
1125                                incr found 1
1126                                while {[gets $fd line] >= 0} {
1127                                        array unset portinfo
1128                                        set name [lindex $line 0]
1129                                        gets $fd line
1130                                       
1131                                        if {$easy} {
1132                                                set target $name
1133                                        } else {
1134                                                array set portinfo $line
1135                                                if {![info exists portinfo($field)]} continue
1136                                                set target $portinfo($field)
1137                                        }
1138                                       
1139                                        switch $matchstyle {
1140                                                exact   { set matchres [expr 0 == ( {$case_sensitive == "yes"} ? [string compare $pattern $target] : [string compare -nocase $pattern $target] )] }
1141                                                glob    { set matchres [expr {$case_sensitive == "yes"} ? [string match $pattern $target] : [string match -nocase $pattern $target]] }
1142                                                regexp  -
1143                                                default { set matchres [expr {$case_sensitive == "yes"} ? [regexp -- $pattern $target] : [regexp -nocase -- $pattern $target]] }
1144                                        }
1145                                       
1146                                        if {$matchres == 1} {
1147                                                if {$easy} {
1148                                                        array set portinfo $line
1149                                                }
1150                                                switch -regexp -- [darwinports::getprotocol ${source}] {
1151                                                        {^rsync$} {
1152                                                                # Rsync files are local
1153                                                                set source_url "file://[darwinports::getsourcepath $source]"
1154                                                        }
1155                                                        default {
1156                                                                set source_url $source
1157                                                        }
1158                                                }
1159                                                if {[info exists portinfo(portarchive)]} {
1160                                                        set porturl ${source_url}/$portinfo(portarchive)
1161                                                } elseif {[info exists portinfo(portdir)]} {
1162                                                        set porturl ${source_url}/$portinfo(portdir)
1163                                                }
1164                                                if {[info exists porturl]} {
1165                                                        lappend line porturl $porturl
1166                                                        ui_debug "Found port in $porturl"
1167                                                } else {
1168                                                        ui_debug "Found port info: $line"
1169                                                }
1170                                                lappend matches $name
1171                                                lappend matches $line
1172                                        }
1173                                }
1174                                close $fd
1175                        }
1176                }
1177        }
1178        if {!$found} {
1179                return -code error "No index(es) found! Have you synced your source indexes?"
1180        }
1181
1182        return $matches
1183}
1184
1185proc dportinfo {dport} {
1186        set workername [ditem_key $dport workername]
1187    return [$workername eval array get PortInfo]
1188}
1189
1190proc dportclose {dport} {
1191        global darwinports::open_dports
1192        set refcnt [ditem_key $dport refcnt]
1193        incr refcnt -1
1194        ditem_key $dport refcnt $refcnt
1195        if {$refcnt == 0} {
1196                dlist_delete darwinports::open_dports $dport
1197                set workername [ditem_key $dport workername]
1198                interp delete $workername
1199        }
1200}
1201
1202##### Private Depspec API #####
1203# This API should be considered work in progress and subject to change without notice.
1204##### "
1205
1206# _dportkey
1207# - returns a variable from the port's interpreter
1208
1209proc _dportkey {dport key} {
1210        set workername [ditem_key $dport workername]
1211        return [$workername eval "return \$${key}"]
1212}
1213
1214# dportdepends builds the list of dports which the given port depends on.
1215# This list is added to $dport.
1216# This list actually depends on the target.
1217# This method can optionally recurse through the dependencies, looking for
1218#   dependencies of dependencies.
1219# This method can optionally cut the search when ports are already installed or
1220#   the dependencies are satisfied.
1221#
1222# dport -> dport item
1223# target -> target to consider the dependency for
1224# recurseDeps -> if the search should be recursive
1225# skipSatisfied -> cut the search tree when encountering installed/satisfied
1226#                  dependencies ports.
1227# accDeps -> accumulator for recursive calls
1228# return 0 if everything was ok, an non zero integer otherwise.
1229proc dportdepends {dport {target ""} {recurseDeps 1} {skipSatisfied 1} {accDeps {}}} {
1230
1231        array set portinfo [dportinfo $dport]
1232        set depends {}
1233        set deptypes {}
1234       
1235        # Determine deptypes to look for based on target
1236        switch $target {
1237                configure       { set deptypes "depends_lib" }
1238               
1239                build           { set deptypes "depends_lib depends_build" }
1240               
1241                destroot        -
1242                install         -
1243                archive         -
1244                pkg                     -
1245                mpkg            -
1246                rpmpackage      -
1247                dpkg            -
1248                ""                      { set deptypes "depends_lib depends_build depends_run" }
1249        }
1250       
1251        # Gather the dependencies for deptypes
1252        foreach deptype $deptypes {
1253                # Add to the list of dependencies if the option exists and isn't empty.
1254                if {[info exists portinfo($deptype)] && $portinfo($deptype) != ""} {
1255                        set depends [concat $depends $portinfo($deptype)]
1256                }
1257        }
1258
1259        set subPorts {}
1260       
1261        foreach depspec $depends {
1262                # grab the portname portion of the depspec
1263                set dep_portname [lindex [split $depspec :] end]
1264               
1265                # Find the porturl
1266                if {[catch {set res [dportsearch $dep_portname false exact]} error]} {
1267                        global errorInfo
1268                        ui_debug "$errorInfo"
1269                        ui_error "Internal error: port search failed: $error"
1270                        return 1
1271                }
1272                foreach {name array} $res {
1273                        array set portinfo $array
1274                        if {[info exists portinfo(porturl)]} {
1275                                set porturl $portinfo(porturl)
1276                                break
1277                        }
1278                }
1279
1280                if {![info exists porturl]} {
1281                        ui_error "Dependency '$dep_portname' not found."
1282                        return 1
1283                }
1284
1285                set options [ditem_key $dport options]
1286                set variations [ditem_key $dport variations]
1287
1288                # Figure out the subport.       
1289                set subport [dportopen $porturl $options $variations]
1290
1291                # Is that dependency satisfied or this port installed?
1292                # If we don't skip or if it is not, add it to the list.
1293                if {!$skipSatisfied || ![_dportispresent $subport $depspec]} {
1294                        # Append the sub-port's provides to the port's requirements list.
1295                        ditem_append_unique $dport requires "[ditem_key $subport provides]"
1296       
1297                        if {$recurseDeps} {
1298                                # Skip the port if it's already in the accumulated list.
1299                                if {[lsearch $accDeps $dep_portname] == -1} {
1300                                        # Add it to the list
1301                                        lappend accDeps $dep_portname
1302                               
1303                                        # We'll recursively iterate on it.
1304                                        lappend subPorts $subport
1305                                }
1306                        }
1307                }
1308        }
1309
1310        # Loop on the subports.
1311        if {$recurseDeps} {
1312                foreach subport $subPorts {
1313                        # Sub ports should be installed (all dependencies must be satisfied).
1314                        set res [dportdepends $subport "" $recurseDeps $skipSatisfied $accDeps]
1315                        if {$res != 0} {
1316                                return $res
1317                        }
1318                }
1319        }
1320       
1321        return 0
1322}
1323
1324# selfupdate procedure
1325proc darwinports::selfupdate {optionslist} {
1326        global darwinports::prefix darwinports::rsync_server darwinports::rsync_dir darwinports::rsync_options
1327        array set options $optionslist
1328
1329        if { [info exists options(ports_force)] && $options(ports_force) == "yes" } {
1330                set use_the_force_luke yes
1331                ui_debug "Forcing a rebuild of the darwinports base system."
1332        } else {
1333                set use_the_force_luke no
1334                ui_debug "Rebuilding the darwinports base system if needed."
1335        }
1336        # syncing ports tree. We expect the user have rsync:// in the sources.conf
1337        if {[catch {dportsync} result]} {
1338                return -code error "Couldn't sync dports tree: $result"
1339        }
1340
1341        set dp_base_path [file join $prefix var/db/dports/sources/rsync.${rsync_server}_${rsync_dir}/]
1342        if {![file exists $dp_base_path]} {
1343                file mkdir $dp_base_path
1344        }
1345        ui_debug "DarwinPorts base dir: $dp_base_path"
1346
1347        # get user of the darwinports system
1348        set user [file attributes [file join $prefix var/db/dports/sources/] -owner]
1349        ui_debug "Setting user: $user"
1350
1351        # get darwinports version
1352        set dp_version_path [file join ${prefix}/etc/ports/ dp_version]
1353        if { [file exists $dp_version_path]} {
1354                set fd [open $dp_version_path r]
1355                gets $fd dp_version_old
1356                close $fd
1357        } else {
1358                set dp_version_old 0
1359        }
1360        ui_msg "DarwinPorts base version $dp_version_old installed"
1361
1362        ui_debug "Updating using rsync"
1363        if { [catch { system "rsync $rsync_options rsync://${rsync_server}/${rsync_dir} $dp_base_path" } ] } {
1364                return -code error "Error: rsync failed in selfupdate"
1365        }
1366
1367        # get downloaded darwinports version and write the old version back
1368        set fd [open [file join $dp_base_path config/dp_version] r]
1369        gets $fd dp_version_new
1370        close $fd
1371        ui_msg "Downloaded DarwinPorts base version $dp_version_new"
1372
1373        # check if we we need to rebuild base
1374        if {$dp_version_new > $dp_version_old || $use_the_force_luke == "yes"} {
1375                ui_msg "Configuring, Building and Installing new DarwinPorts base"
1376                # check if $prefix/bin/port is writable, if so we go !
1377                # get installation user / group
1378                set owner root
1379                set group admin
1380                if {[file exists [file join $prefix bin/port] ]} {
1381                        # set owner
1382                        set owner [file attributes [file join $prefix bin/port] -owner]
1383                        # set group
1384                        set group [file attributes [file join $prefix bin/port] -group]
1385                }
1386                set p_user [exec /usr/bin/whoami]
1387                if {[file writable ${prefix}/bin/port] || [string equal $p_user $owner] } {
1388                        ui_debug "permissions OK"
1389                } else {
1390                        return -code error "Error: $p_user cannot write to ${prefix}/bin - try using sudo"
1391                }
1392                ui_debug "Setting owner: $owner group: $group"
1393
1394                set dp_tclpackage_path [file join $prefix var/db/dports/ .tclpackage]
1395                if { [file exists $dp_tclpackage_path]} {
1396                        set fd [open $dp_tclpackage_path r]
1397                        gets $fd tclpackage
1398                        close $fd
1399                } else {
1400                        set tclpackage [file join ${prefix} share/darwinports/Tcl]
1401                }
1402                # do the actual installation of new base
1403                ui_debug "Install in: $prefix as $owner : $group - TCL-PACKAGE in $tclpackage"
1404                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] } {
1405                        return -code error "Error installing new DarwinPorts base: $result"
1406                }
1407        } else {
1408                ui_msg "The DarwinPorts installation is not outdated and so was not updated"
1409        }
1410
1411        # set the darwinports system to the right owner
1412        ui_debug "Setting ownership to $user"
1413        if { [catch { exec chown -R $user [file join $prefix var/db/dports/sources/] } result] } {
1414                return -code error "Couldn't change permissions: $result"
1415        }
1416
1417        # set the right version
1418        ui_msg "selfupdate done!"
1419
1420        return 0
1421}
1422
1423proc darwinports::version {} {
1424        global darwinports::prefix darwinports::rsync_server darwinports::rsync_dir
1425       
1426        set dp_version_path [file join $prefix etc/ports/ dp_version]
1427
1428        if [file exists $dp_version_path] {
1429                set fd [open $dp_version_path r]
1430                gets $fd retval
1431                return $retval
1432        } else {
1433                return -1
1434        }
1435}
1436
1437# upgrade procedure
1438proc darwinports::upgrade {portname dspec variationslist optionslist {depscachename ""}} {
1439    global darwinports::registry.installtype
1440        array set options $optionslist
1441        array set variations $variationslist
1442        if {![string match "" $depscachename]} {
1443                upvar $depscachename depscache
1444        } 
1445
1446        # set to no-zero is epoch overrides version
1447        set epoch_override 0
1448
1449        # check if the port is in tree
1450        if {[catch {dportsearch $portname false exact} result]} {
1451                global errorInfo
1452                ui_debug "$errorInfo"
1453                ui_error "port search failed: $result"
1454                return 1
1455        }
1456        # argh! port doesnt exist!
1457        if {$result == ""} {
1458                ui_error "No port $portname found."
1459                return 1
1460        }
1461        # fill array with information
1462        array set portinfo [lindex $result 1]
1463
1464        # set version_in_tree
1465        if {![info exists portinfo(version)]} {
1466                ui_error "Invalid port entry for $portname, missing version"
1467                return 1
1468        }
1469        set version_in_tree "$portinfo(version)_$portinfo(revision)"
1470        set epoch_in_tree "$portinfo(epoch)"
1471
1472        # the depflag tells us if we should follow deps (this is for stuff installed outside DP)
1473        # if this is set (not 0) we dont follow the deps
1474        set depflag 0
1475
1476        # set version_installed
1477        set ilist {}
1478        if { [catch {set ilist [registry::installed $portname ""]} result] } {
1479                if {$result == "Registry error: $portname not registered as installed." } {
1480                        ui_debug "$portname is *not* installed by DarwinPorts"
1481                        # open porthandle   
1482                        set porturl $portinfo(porturl)
1483                    if {![info exists porturl]} {
1484                        set porturl file://./   
1485                        }   
1486                        if {[catch {set workername [dportopen $porturl [array get options] ]} result]} {
1487                                        global errorInfo
1488                                        ui_debug "$errorInfo"
1489                                ui_error "Unable to open port: $result"       
1490                                        return 1
1491                    }
1492
1493                        if {![_dportispresent $workername $dspec ] } {
1494                                # port in not installed - install it!
1495                                if {[catch {set result [dportexec $workername install]} result]} {
1496                                        global errorInfo
1497                                        ui_debug "$errorInfo"
1498                                        ui_error "Unable to exec port: $result"
1499                                        return 1
1500                                }
1501                        } else {
1502                                # port installed outside DP
1503                                ui_debug "$portname installed outside the DarwinPorts system"
1504                                set depflag 1
1505                        }
1506
1507                } else {
1508                        ui_error "Checking installed version failed: $result"
1509                        exit 1
1510                }
1511        }
1512        set anyactive 0
1513        set version_installed 0
1514        set epoch_installed 0
1515        if {$ilist == ""} {
1516                # XXX  this sets $version_installed to $version_in_tree even if not installed!!
1517                set version_installed $version_in_tree
1518        } else {
1519                # a port could be installed but not activated
1520                # so, deactivate all and save newest for activation later
1521                set num 0
1522                set variant ""
1523                foreach i $ilist {
1524                        set variant [lindex $i 3]
1525                        set version "[lindex $i 1]_[lindex $i 2]"
1526                        if { [rpm-vercomp $version $version_installed] > 0} {
1527                                set version_installed $version
1528                                set epoch_installed [registry::property_retrieve [registry::open_entry $portname [lindex $i 1] [lindex $i 2] $variant] epoch]
1529                                set num $i
1530                        }
1531
1532                        set isactive [lindex $i 4]
1533                        if {$isactive == 1 && [rpm-vercomp $version_installed $version] < 0 } {
1534                                # deactivate version
1535                        if {[catch {portimage::deactivate $portname $version $optionslist} result]} {
1536                                        global errorInfo
1537                                        ui_debug "$errorInfo"
1538                        ui_error "Deactivating $portname $version_installed failed: $result"
1539                        return 1
1540                        }
1541                        }
1542                }
1543        if { [lindex $num 4] == 0 && 0 == [string compare "image" ${darwinports::registry.installtype}] } {
1544                        # activate the latest installed version
1545                        if {[catch {portimage::activate $portname $version_installed$variant $optionslist} result]} {
1546                                global errorInfo
1547                                ui_debug "$errorInfo"
1548                        ui_error "Activating $portname $version_installed failed: $result"
1549                                return 1
1550                        }
1551                }
1552        }
1553
1554        # output version numbers
1555        ui_debug "epoch: in tree: $epoch_in_tree installed: $epoch_installed"
1556        ui_debug "$portname $version_in_tree exists in the ports tree"
1557        ui_debug "$portname $version_installed is installed"
1558
1559        # set the nodeps option 
1560        if {![info exists options(ports_nodeps)]} {
1561                set nodeps no
1562        } else {       
1563                set nodeps yes
1564        }
1565
1566        if {$nodeps == "yes" || $depflag == 1} {
1567                ui_debug "Not following dependencies"
1568                set depflag 0
1569        } else {
1570                # build depends is upgraded
1571                if {[info exists portinfo(depends_build)]} {
1572                        foreach i $portinfo(depends_build) {
1573                                if {![llength [array get depscache $i]]} {
1574                                set d [lindex [split $i :] end]
1575                                        set depscache($i) 1
1576                                        upgrade $d $i $variationslist $optionslist depscache
1577                                } 
1578                        }
1579                }
1580                # library depends is upgraded
1581                if {[info exists portinfo(depends_lib)]} {
1582                        foreach i $portinfo(depends_lib) {
1583                                if {![llength [array get depscache $i]]} {
1584                                set d [lindex [split $i :] end]
1585                                        set depscache($i) 1
1586                                        upgrade $d $i $variationslist $optionslist depscache
1587                                } 
1588                        }
1589                }
1590                # runtime depends is upgraded
1591                if {[info exists portinfo(depends_run)]} {
1592                        foreach i $portinfo(depends_run) {
1593                                if {![llength [array get depscache $i]]} {
1594                                set d [lindex [split $i :] end]
1595                                        set depscache($i) 1
1596                                        upgrade $d $i $variationslist $optionslist depscache
1597                                } 
1598                        }
1599                }
1600        }
1601
1602        # check installed version against version in ports
1603        if { [rpm-vercomp $version_installed $version_in_tree] >= 0 && ![info exists options(ports_force)] } {
1604                ui_debug "No need to upgrade! $portname $version_installed >= $portname $version_in_tree"
1605                if { $epoch_installed >= $epoch_in_tree } {
1606                        # Check if we have to do dependents
1607                        if {[info exists options(ports_do_dependents)]} {
1608                                # We do dependents ..
1609                                set options(ports_nodeps) 1
1610
1611                                registry::open_dep_map
1612                                set deplist [registry::list_dependents $portname]
1613
1614                                if { [llength deplist] > 0 } {
1615                                        foreach dep $deplist {
1616                                                set dpname [lindex $dep 2] 
1617                                                darwinports::upgrade $dpname "port:$dpname" [array get variations] [array get options]
1618                                        }
1619                                }
1620                        }
1621
1622                        return 0
1623                } else {
1624                        ui_debug "epoch override ... upgrading!"
1625                        set epoch_override 1
1626                }
1627        }
1628
1629        # open porthandle
1630        set porturl $portinfo(porturl)
1631        if {![info exists porturl]} {
1632                set porturl file://./
1633        }
1634
1635        # check if the variants is present in $version_in_tree
1636        set oldvariant $variant
1637        set variant [split $variant +]
1638        ui_debug "variants to install $variant"
1639        if {[info exists portinfo(variants)]} {
1640                set avariants $portinfo(variants)
1641        } else {
1642                set avariants {}
1643        }
1644        ui_debug "available variants are : $avariants"
1645        foreach v $variant {
1646                if {[lsearch $avariants $v] == -1} {
1647                } else {
1648                        ui_debug "variant $v is present in $portname $version_in_tree"
1649                        set variations($v) "+"
1650                }
1651        }
1652        ui_debug "new portvariants: [array get variations]"
1653       
1654        if {[catch {set workername [dportopen $porturl [array get options] [array get variations]]} result]} {
1655                global errorInfo
1656                ui_debug "$errorInfo"
1657                ui_error "Unable to open port: $result"
1658                return 1
1659        }
1660
1661        # install version_in_tree
1662        if {[catch {set result [dportexec $workername destroot]} result] || $result != 0} {
1663                global errorInfo
1664                ui_debug "$errorInfo"
1665                ui_error "Unable to upgrade port: $result"
1666                return 1
1667        }
1668
1669        # uninstall old ports
1670    if {[info exists options(port_uninstall_old)] || $epoch_override == 1 || [info exists options(ports_force)] || 0 != [string compare "image" ${darwinports::registry.installtype}] } {
1671                # uninstall old
1672                ui_debug "Uninstalling $portname $version_installed$oldvariant"
1673                if {[catch {portuninstall::uninstall $portname $version_installed$oldvariant $optionslist} result]} {
1674                        global errorInfo
1675                        ui_debug "$errorInfo"
1676                ui_error "Uninstall $portname $version_installed$oldvariant failed: $result"
1677                return 1
1678        }
1679        } else {
1680                # XXX deactivate version_installed
1681                if {[catch {portimage::deactivate $portname $version_installed$oldvariant $optionslist} result]} {
1682                        global errorInfo
1683                        ui_debug "$errorInfo"
1684                        ui_error "Deactivating $portname $version_installed failed: $result"
1685                        return 1
1686                }
1687        }
1688
1689        if {[catch {set result [dportexec $workername install]} result]} {
1690                global errorInfo
1691                ui_debug "$errorInfo"
1692                ui_error "Couldn't activate $portname $version_in_tree$oldvariant: $result"
1693                return 1
1694        }
1695
1696        # Check if we have to do dependents
1697        if {[info exists options(ports_do_dependents)]} {
1698                # We do dependents ..
1699                set options(ports_nodeps) 1
1700
1701                registry::open_dep_map
1702                set deplist [registry::list_dependents $portname]
1703
1704                if { [llength deplist] > 0 } {
1705                        foreach dep $deplist {
1706                                set dpname [lindex $dep 2] 
1707                                darwinports::upgrade $dpname "port:$dpname" [array get variations] [array get options]
1708                        }
1709                }
1710        }
1711
1712       
1713        # close the port handle
1714        dportclose $workername
1715}
Note: See TracBrowser for help on using the repository browser.