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

Last change on this file since 7142 was 7142, checked in by kevin, 16 years ago

Use regular expression in remote index searching.

  • Property svn:eol-style set to native
File size: 27.0 KB
Line 
1# darwinports.tcl
2#
3# Copyright (c) 2002 Apple Computer, Inc.
4# All rights reserved.
5#
6# Redistribution and use in source and binary forms, with or without
7# modification, are permitted provided that the following conditions
8# are met:
9# 1. Redistributions of source code must retain the above copyright
10#    notice, this list of conditions and the following disclaimer.
11# 2. Redistributions in binary form must reproduce the above copyright
12#    notice, this list of conditions and the following disclaimer in the
13#    documentation and/or other materials provided with the distribution.
14# 3. Neither the name of Apple Computer, Inc. nor the names of its contributors
15#    may be used to endorse or promote products derived from this software
16#    without specific prior written permission.
17#
18# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
19# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
20# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
21# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
22# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
23# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
24# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
25# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
26# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
27# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
28# POSSIBILITY OF SUCH DAMAGE.
29#
30package provide darwinports 1.0
31package require darwinports_dlist 1.0
32package require darwinports_index 1.0
33
34namespace eval darwinports {
35    namespace export bootstrap_options portinterp_options open_dports
36    variable bootstrap_options "portdbpath libpath binpath master_site_local auto_path sources_conf prefix"
37    variable portinterp_options "portdbpath portpath auto_path prefix portsharepath registry.path"
38       
39    variable open_dports {}
40}
41
42# Provided UI instantiations
43# For standard messages, the following priorities are defined
44#     debug, info, msg, warn, error
45# Clients of the library are expected to provide ui_puts with the following prototype.
46#     proc ui_puts {message}
47# message is a tcl list of array element pairs, defined as such:
48#     version   - ui protocol version
49#     priority  - message priority
50#     data      - message data
51# ui_puts should handle the above defined priorities
52
53foreach priority "debug info msg error warn" {
54    eval "proc ui_$priority {str} \{ \n\
55        set message(priority) $priority \n\
56        set message(data) \$str \n\
57        ui_puts \[array get message\] \n\
58    \}"
59}
60
61proc darwinports::ui_event {context message} {
62    array set postmessage $message
63    set postmessage(context) $context
64    ui_puts [array get postmessage]
65}
66
67proc dportinit {args} {
68    global auto_path env darwinports::portdbpath darwinports::bootstrap_options darwinports::portinterp_options darwinports::portconf darwinports::sources darwinports::sources_conf darwinports::portsharepath darwinports::registry.path darwinports::autoconf::dports_conf_path
69
70    # first look at PORTSRC for testing/debugging
71    if {[llength [array names env PORTSRC]] > 0} {
72        set PORTSRC [lindex [array get env PORTSRC] 1]
73        if {[file isfile ${PORTSRC}]} {
74            set portconf ${PORTSRC}
75            lappend conf_files ${portconf}
76        }
77    }
78
79    # then look in ~/.portsrc
80    if {![info exists portconf]} {
81        if {[llength [array names env HOME]] > 0} {
82            set HOME [lindex [array get env HOME] 1]
83            if {[file isfile [file join ${HOME} .portsrc]]} {
84                set portconf [file join ${HOME} .portsrc]
85                lappend conf_files ${portconf}
86            }
87        }
88    }
89
90    # finally /etc/ports/ports.conf, or whatever path was configured
91    if {![info exists portconf]} {
92        if {[file isfile $dports_conf_path/ports.conf]} {
93            set portconf $dports_conf_path/ports.conf
94            lappend conf_files $dports_conf_path/ports.conf
95        }
96    }
97    if {[info exists conf_files]} {
98        foreach file $conf_files {
99            set fd [open $file r]
100            while {[gets $fd line] >= 0} {
101                foreach option $bootstrap_options {
102                    if {[regexp "^$option\[ \t\]+(\[A-Za-z0-9_:\./\]+$)" $line match val] == 1} {
103                        set darwinports::$option $val
104                        global darwinports::$option
105                    }
106                }
107            }
108        }
109    }
110
111    if {![info exists sources_conf]} {
112        return -code error "sources_conf must be set in $dports_conf_path/ports.conf or in your ~/.portsrc"
113    }
114    if {[catch {set fd [open $sources_conf r]} result]} {
115        return -code error "$result"
116    }
117    while {[gets $fd line] >= 0} {
118        set line [string trimright $line]
119        if {![regexp {[\ \t]*#.*|^$} $line]} {
120            lappend sources $line
121        }
122    }
123    if {![info exists sources]} {
124        if {[file isdirectory dports]} {
125            set sources "file://[pwd]/dports"
126        } else {
127            return -code error "No sources defined in $sources_conf"
128        }
129    }
130
131    if {![info exists portdbpath]} {
132        return -code error "portdbpath must be set in $dports_conf_path/ports.conf or in your ~/.portsrc"
133    }
134    if {![file isdirectory $portdbpath]} {
135        if {![file exists $portdbpath]} {
136            if {[catch {file mkdir $portdbpath} result]} {
137                return -code error "portdbpath $portdbpath does not exist and could not be created: $result"
138            }
139        }
140    }
141    if {![file isdirectory $portdbpath]} {
142        return -code error "$portdbpath is not a directory. Please create the directory $portdbpath and try again"
143    }
144
145    set registry.path [file join $portdbpath receipts]
146    if {![file isdirectory ${registry.path}]} {
147        if {![file exists ${registry.path}]} {
148            if {[catch {file mkdir ${registry.path}} result]} {
149                return -code error "portdbpath ${registry.path} does not exist and could not be created: $result"
150            }
151        }
152    }
153    if {![file isdirectory ${darwinports::registry.path}]} {
154        return -code error "${darwinports::registry.path} is not a directory. Please create the directory $portdbpath and try again"
155    }
156
157    set portsharepath ${prefix}/share/darwinports
158    if {![file isdirectory $portsharepath]} {
159        return -code error "Data files directory '$portsharepath' must exist"
160    }
161   
162    if {![info exists libpath]} {
163        set libpath "${prefix}/share/darwinports/Tcl"
164    }
165
166    if {![info exists binpath]} {
167        global env
168        set env(PATH) "${prefix}/bin:${prefix}/sbin:/bin:/sbin:/usr/bin:/usr/sbin:/usr/X11R6/bin"
169    } else {
170        global env
171        set env(PATH) "$binpath"
172    }
173
174    if {[info exists master_site_local] && ![info exists env(MASTER_SITE_LOCAL)]} {
175        global env
176        set env(MASTER_SITE_LOCAL) "$master_site_local"
177    }
178
179    if {[file isdirectory $libpath]} {
180                lappend auto_path $libpath
181                set darwinports::auto_path $auto_path
182
183                # XXX: not sure if this the best place, but it needs to happen
184                # early, and after auto_path has been set.  Or maybe Pextlib
185                # should ship with darwinports1.0 API?
186                package require Pextlib 1.0
187    } else {
188                return -code error "Library directory '$libpath' must exist"
189    }
190}
191
192proc darwinports::worker_init {workername portpath options variations} {
193    global darwinports::portinterp_options auto_path
194
195    # Create package require abstraction procedure
196    $workername eval "proc PortSystem \{version\} \{ \n\
197                        package require port \$version \}"
198
199    foreach proc {dportexec dportopen dportclose dportsearch} {
200        $workername alias $proc $proc
201    }
202
203    # instantiate the UI call-back
204    $workername alias ui_event darwinports::ui_event $workername
205
206        # xxx: find a better home for this registry cruft--like six feet under.
207        $workername alias registry_new dportregistry::new $workername
208        $workername alias registry_store dportregistry::store
209        $workername alias registry_delete dportregistry::delete
210        $workername alias registry_exists dportregistry::exists
211        $workername alias registry_close dportregistry::close
212        $workername alias fileinfo_for_index dportregistry::fileinfo_for_index
213        $workername alias fileinfo_for_file dportregistry::fileinfo_for_file
214        $workername alias fileinfo_for_entry dportregistry::fileinfo_for_entry
215
216    foreach opt $portinterp_options {
217        if {![info exists $opt]} {
218            global darwinports::$opt
219        }
220        if {[info exists $opt]} {
221            $workername eval set system_options($opt) \"[set $opt]\"
222            $workername eval set $opt \"[set $opt]\"
223        } #"
224    }
225
226    foreach {opt val} $options {
227        $workername eval set user_options($opt) $val
228        $workername eval set $opt $val
229    }
230
231    foreach {var val} $variations {
232        $workername eval set variations($var) $val
233    }
234}
235
236proc darwinports::fetch_port {url} {
237    global darwinports::portdbpath tcl_platform
238    set fetchdir [file join $portdbpath portdirs]
239    set fetchfile [file tail $url]
240    if {[catch {file mkdir $fetchdir} result]} {
241        return -code error $result
242    }
243    if {![file writable $fetchdir]} {
244        return -code error "Port remote fetch failed: You do not have permission to write to $fetchdir"
245    }
246    if {[catch {exec curl -L -s -S -o [file join $fetchdir $fetchfile] $url} result]} {
247        return -code error "Port remote fetch failed: $result"
248    }
249    if {[catch {cd $fetchdir} result]} {
250        return -code error $result
251    }
252    if {[catch {exec tar -zxf $fetchfile} result]} {
253        return -code error "Port extract failed: $result"
254    }
255    if {[regexp {(.+).tgz} $fetchfile match portdir] != 1} {
256        return -code error "Can't decipher portdir from $fetchfile"
257    }
258
259    return [file join $fetchdir $portdir]
260}
261
262proc darwinports::getprotocol {url} {
263    if {[regexp {(?x)([^:]+)://.+} $url match protocol] == 1} {
264        return ${protocol}
265    } else {
266        return -code error "Can't parse url $url"
267    }
268}
269
270proc darwinports::getportdir {url} {
271    if {[regexp {(?x)([^:]+)://(.+)} $url match protocol string] == 1} {
272        switch -regexp -- ${protocol} {
273            {^file$} { return $string}
274        {dports} { return [darwinports::index::fetch_port $url] }
275            {http|ftp} { return [darwinports::fetch_port $url] }
276            default { return -code error "Unsupported protocol $protocol" }
277        }
278    } else {
279        return -code error "Can't parse url $url"
280    }
281}
282
283# dportopen
284# Opens a DarwinPorts portfile specified by a URL.  The portfile is
285# opened with the given list of options and variations.  The result
286# of this function should be treated as an opaque handle to a
287# DarwinPorts Portfile.
288
289proc dportopen {porturl {options ""} {variations ""}} {
290    global darwinports::portinterp_options darwinports::portdbpath darwinports::portconf darwinports::open_dports auto_path
291
292        # Look for an already-open DPort with the same URL.
293        # XXX: should compare options and variations here too.
294        # if found, return the existing reference and bump the refcount.
295        set dport [dlist_search $darwinports::open_dports porturl $porturl]
296        if {$dport != {}} {
297                set refcnt [ditem_key $dport refcnt]
298                incr refcnt
299                ditem_key $dport refcnt $refcnt
300                return $dport
301        }
302
303        set portdir [darwinports::getportdir $porturl]
304        cd $portdir
305        set portpath [pwd]
306        set workername [interp create]
307
308        set dport [ditem_create]
309        lappend darwinports::open_dports $dport
310        ditem_key $dport porturl $porturl
311        ditem_key $dport portpath $portpath
312        ditem_key $dport workername $workername
313        ditem_key $dport options $options
314        ditem_key $dport variations $variations
315        ditem_key $dport refcnt 1
316
317    darwinports::worker_init $workername $portpath $options $variations
318    if {![file isfile Portfile]} {
319        return -code error "Could not find Portfile in $portdir"
320    }
321
322    $workername eval source Portfile
323       
324    ditem_key $dport provides [$workername eval return \$portname]
325
326    return $dport
327}
328
329### _dportsearchpath is private; subject to change without notice
330
331proc _dportsearchpath {depregex search_path} {
332    set found 0
333    foreach path $search_path {
334        if {![file isdirectory $path]} {
335            continue
336        }
337
338        if {[catch {set filelist [readdir $path]} result]} {
339                return -code error "$result ($path)"
340                set filelist ""
341        }
342
343        foreach filename $filelist {
344            if {[regexp $depregex $filename] == 1} {
345                ui_debug "Found Dependency: path: $path filename: $filename regex: $depregex"
346                set found 1
347                break
348            }
349        }
350    }
351
352    return $found
353}
354
355### _libtest is private; subject to change without notice
356# XXX - Architecture specific
357# XXX - Rely on information from internal defines in cctools/dyld:
358# define DEFAULT_FALLBACK_FRAMEWORK_PATH
359# /Library/Frameworks:/Library/Frameworks:/Network/Library/Frameworks:/System/Library/Frameworks
360# define DEFAULT_FALLBACK_LIBRARY_PATH /lib:/usr/local/lib:/lib:/usr/lib
361#   -- Since /usr/local is bad, using /lib:/usr/lib only.
362# Environment variables DYLD_FRAMEWORK_PATH, DYLD_LIBRARY_PATH,
363# DYLD_FALLBACK_FRAMEWORK_PATH, and DYLD_FALLBACK_LIBRARY_PATH take precedence
364
365proc _libtest {dport depspec} {
366    global env tcl_platform
367        set depline [lindex [split $depspec :] 1]
368        set prefix [_dportkey $dport prefix]
369       
370        if {[info exists env(DYLD_FRAMEWORK_PATH)]} {
371            lappend search_path $env(DYLD_FRAMEWORK_PATH)
372        } else {
373            lappend search_path /Library/Frameworks /Network/Library/Frameworks /System/Library/Frameworks
374        }
375        if {[info exists env(DYLD_FALLBACK_FRAMEWORK_PATH)]} {
376            lappend search_path $env(DYLD_FALLBACK_FRAMEWORK_PATH)
377        }
378        if {[info exists env(DYLD_LIBRARY_PATH)]} {
379            lappend search_path $env(DYLD_LIBRARY_PATH)
380        }
381        lappend search_path /lib /usr/lib /usr/X11R6/lib ${prefix}/lib
382        if {[info exists env(DYLD_FALLBACK_LIBRARY_PATH)]} {
383            lappend search_path $env(DYLD_LIBRARY_PATH)
384        }
385
386        set i [string first . $depline]
387        set depname [string range $depline 0 [expr $i - 1]]
388        set depversion [string range $depline $i end]
389        regsub {\.} $depversion {\.} depversion
390        if {$tcl_platform(os) == "Darwin"} {
391                set depregex \^${depname}${depversion}\\.dylib\$
392        } else {
393                set depregex \^${depname}\\.so${depversion}\$
394        }
395
396        return [_dportsearchpath $depregex $search_path]
397}
398
399### _bintest is private; subject to change without notice
400
401proc _bintest {dport depspec} {
402    global env
403        set depregex [lindex [split $depspec :] 1]
404        set prefix [_dportkey $dport prefix] 
405       
406        set search_path [split $env(PATH) :]
407       
408        set depregex \^$depregex\$
409       
410        return [_dportsearchpath $depregex $search_path]
411}
412
413### _pathtest is private; subject to change without notice
414
415proc _pathtest {dport depspec} {
416    global env
417        set depregex [lindex [split $depspec :] 1]
418        set prefix [_dportkey $dport prefix] 
419   
420        # separate directory from regex
421        set fullname $depregex
422
423        regexp {^(.*)/(.*?)$} "$fullname" match search_path depregex
424
425        if {[string index $search_path 0] != "/"} {
426                # Prepend prefix if not an absolute path
427                set search_path "${prefix}/${search_path}"
428        }
429
430        set depregex \^$depregex\$
431
432        return [_dportsearchpath $depregex $search_path]
433}
434
435### _dportinstalled is private; may change without notice
436
437# Determine if a port is already *installed*, as in "in the registry".
438proc _dportinstalled {dport} {
439        # Check for the presense of the port in the registry
440        set workername [ditem_key $dport workername]
441        set res [$workername eval registry_exists \${portname} \${portversion}]
442        if {$res != ""} {
443                ui_debug "Found Dependency: receipt: $res"
444                return 1
445        } else {
446                return 0
447        }
448}
449
450### _dporispresent is private; may change without notice
451
452# Determine if some depspec is satisfied or if the given port is installed.
453# We actually start with the registry (faster?)
454#
455# dport         the port to test (to figure out if it's present)
456# depspec       the dependency test specification (path, bin, lib, etc.)
457proc _dportispresent {dport depspec} {
458        # Check for the presense of the port in the registry
459        set workername [ditem_key $dport workername]
460        set res [$workername eval registry_exists \${portname} \${portversion}]
461        if {$res != ""} {
462                ui_debug "Found Dependency: receipt: $res"
463                return 1
464        } else {
465                # The receipt test failed, use one of the depspec regex mechanisms
466                set type [lindex [split $depspec :] 0]
467                switch $type {
468                        lib { return [_libtest $dport $depspec] }
469                        bin { return [_bintest $dport $depspec] }
470                        path { return [_pathtest $dport $depspec] }
471                        default {return -code error "unknown depspec type: $type"}
472                }
473                return 0
474        }
475}
476
477### _dportexec is private; may change without notice
478
479proc _dportexec {target dport} {
480        # xxx: set the work path?
481        set workername [ditem_key $dport workername]
482        if {![catch {$workername eval eval_variants variations $target} result] && $result == 0 &&
483                ![catch {$workername eval eval_targets $target} result] && $result == 0} {
484                # xxx: clean after installing?
485                #$workername eval eval_targets clean
486                return 0
487        } else {
488                # An error occurred.
489                return 1
490        }
491}
492
493# dportexec
494# Execute the specified target of the given dport.
495
496proc dportexec {dport target} {
497    global darwinports::portinterp_options
498
499        set workername [ditem_key $dport workername]
500
501        # XXX: move this into dportopen?
502        if {[$workername eval eval_variants variations $target] != 0} {
503                return 1
504        }
505       
506        # Before we build the port, we must build its dependencies.
507        # XXX: need a more general way of comparing against targets
508        set dlist {}
509        if {$target == "package"} {
510                ui_warn "package target replaced by pkg target, please use the pkg target in the future."
511                set target "pkg"
512        }
513        if {$target == "configure" || $target == "build"
514                || $target == "destroot" || $target == "install"
515                || $target == "pkg" || $target == "mpkg"
516                || $target == "rpmpackage" || $target == "dpkg" } {
517
518                if {[dportdepends $dport 1 1] != 0} {
519                        return 1
520                }
521               
522                # Select out the dependents along the critical path,
523                # but exclude this dport, we might not be installing it.
524                set dlist [dlist_append_dependents $darwinports::open_dports $dport {}]
525               
526                dlist_delete dlist $dport
527
528                # install them
529                set result [dlist_eval $dlist _dportinstalled [list _dportexec "install"]]
530               
531                if {$result != {}} {
532                        set errstring "The following dependencies failed to build:"
533                        foreach ditem $result {
534                                append errstring " [ditem_key $ditem provides]"
535                        }
536                        ui_error $errstring
537                        return 1
538                }
539               
540                # Close the dependencies, we're done installing them
541                foreach ditem $dlist {
542                    dportclose $ditem
543                }
544        }
545       
546        # Build this port with the specified target
547        return [$workername eval eval_targets $target]
548       
549        return 0
550}
551
552proc darwinports::getindex {source} {
553    global darwinports::portdbpath
554    # Special case file:// sources
555    if {[darwinports::getprotocol $source] == "file"} {
556        return [file join [darwinports::getportdir $source] PortIndex]
557    }
558    regsub {://} $source {.} source_dir
559    regsub -all {/} $source_dir {_} source_dir
560    return [file join $portdbpath sources $source_dir PortIndex]
561}
562
563proc dportsync {args} {
564    global darwinports::sources darwinports::portdbpath tcl_platform
565
566    foreach source $sources {
567        # Special case file:// sources
568        if {[darwinports::getprotocol $source] == "file"} {
569            continue
570        } elseif {[darwinports::getprotocol $source] == "dports"} {
571                        darwinports::index::sync $darwinports::portdbpath $source
572        } else {
573                        set indexfile [darwinports::getindex $source]
574                        if {[catch {file mkdir [file dirname $indexfile]} result]} {
575                                return -code error $result
576                        }
577                        if {![file writable [file dirname $indexfile]]} {
578                                return -code error "You do not have permission to write to [file dirname $indexfile]"
579                        }
580                        exec curl -L -s -S -o $indexfile $source/PortIndex
581                }
582    }
583}
584
585proc dportsearch {regexp} {
586    global darwinports::portdbpath darwinports::sources
587    set matches [list]
588
589    foreach source $sources {
590        if {[darwinports::getprotocol $source] == "dports"} {
591                array set attrs [list name $regexp]
592                        set res [darwinports::index::search $darwinports::portdbpath $source [array get attrs]]
593                        eval lappend matches $res
594                } else {
595        if {[catch {set fd [open [darwinports::getindex $source] r]} result]} {
596            return -code error "Can't open index file for source $source. Have you synced your source indexes?"
597        }
598        while {[gets $fd line] >= 0} {
599            set name [lindex $line 0]
600            if {[regexp -- $regexp $name] == 1} {
601                gets $fd line
602                array set portinfo $line
603                if {[info exists portinfo(portarchive)]} {
604                    lappend line porturl ${source}/$portinfo(portarchive)
605                } elseif {[info exists portinfo(portdir)]} {
606                    lappend line porturl ${source}/$portinfo(portdir)
607                }
608                lappend matches $name
609                lappend matches $line
610            } else {
611                set len [lindex $line 1]
612                seek $fd $len current
613            }
614        }
615        close $fd
616        }
617    }
618
619    return $matches
620}
621
622proc dportinfo {dport} {
623        set workername [ditem_key $dport workername]
624    return [$workername eval array get PortInfo]
625}
626
627proc dportclose {dport} {
628        global darwinports::open_dports
629        set refcnt [ditem_key $dport refcnt]
630        incr refcnt -1
631        ditem_key $dport refcnt $refcnt
632        if {$refcnt == 0} {
633                dlist_delete darwinports::open_dports $dport
634                set workername [ditem_key $dport workername]
635                interp delete $workername
636        }
637}
638
639##### Private Depspec API #####
640# This API should be considered work in progress and subject to change without notice.
641##### "
642
643# _dportkey
644# - returns a variable from the port's interpreter
645
646proc _dportkey {dport key} {
647        set workername [ditem_key $dport workername]
648        return [$workername eval "return \$${key}"]
649}
650
651# dportdepends builds the list of dports which the given port depends on.
652# This list is added to $dport.
653# - optionally includes the build dependencies in the list.
654# - optionally recurses through the dependencies, looking for dependencies
655#       of dependencies.
656
657proc dportdepends {dport includeBuildDeps recurseDeps {accDeps {}}} {
658        array set portinfo [dportinfo $dport]
659        set depends {}
660        if {[info exists portinfo(depends_run)]} { eval "lappend depends $portinfo(depends_run)" }
661        if {[info exists portinfo(depends_lib)]} { eval "lappend depends $portinfo(depends_lib)" }
662        if {$includeBuildDeps != "" && [info exists portinfo(depends_build)]} {
663                eval "lappend depends $portinfo(depends_build)"
664        }
665
666        set subPorts {}
667       
668        foreach depspec $depends {
669                # grab the portname portion of the depspec
670                set portname [lindex [split $depspec :] 2]
671               
672                # Find the porturl
673                if {[catch {set res [dportsearch "^$portname\$"]} error]} {
674                        ui_error "Internal error: port search failed: $error"
675                        return 1
676                }
677                foreach {name array} $res {
678                        array set portinfo $array
679                        if {[info exists portinfo(porturl)]} {
680                                set porturl $portinfo(porturl)
681                                break
682                        }
683                }
684
685                if {![info exists porturl]} {
686                        ui_error "Dependency '$portname' not found."
687                        return 1
688                }
689
690                set options [ditem_key $dport options]
691                set variations [ditem_key $dport variations]
692
693                # Figure out the subport.       
694                set subport [dportopen $porturl $options $variations]
695
696                # Is that dependency satisfied or this port installed?
697                # If not, add it to the list. Otherwise, don't.
698                if {![_dportispresent $subport $depspec]} {
699                        # Append the sub-port's provides to the port's requirements list.
700                        ditem_append_unique $dport requires "[ditem_key $subport provides]"
701       
702                        if {$recurseDeps != ""} {
703                                # Skip the port if it's already in the accumulated list.
704                                if {[lsearch $accDeps $portname] == -1} {
705                                        # Add it to the list
706                                        lappend accDeps $portname
707                               
708                                        # We'll recursively iterate on it.
709                                        lappend subPorts $subport
710                                }
711                        }
712                }
713        }
714
715        # Loop on the subports.
716        if {$recurseDeps != ""} {
717                foreach subport $subPorts {
718                        set res [dportdepends $subport $includeBuildDeps $recurseDeps $accDeps]
719                        if {$res != 0} {
720                                return $res
721                        }
722                }
723        }
724       
725        return 0
726}
727
728# Snarfed from portregistry.tcl
729# For now, just write stuff to a file for debugging.
730
731namespace eval dportregistry {}
732
733proc dportregistry::new {workername portname {portversion 1.0}} {
734    global _registry_name darwinports::registry.path
735
736    file mkdir ${darwinports::registry.path}
737    set _registry_name [file join ${darwinports::registry.path} $portname-$portversion]
738    system "rm -f ${_registry_name}.tmp"
739    set rhandle [open ${_registry_name}.tmp w 0644]
740    puts $rhandle "\# Format: var value ... {contents {filename uid gid mode size {md5}} ... }"
741        #interp share {} $rhandle $workername
742    return $rhandle
743}
744
745proc dportregistry::exists {portname {portversion 0}} {
746    global darwinports::registry.path
747
748    # regex match case
749    if {$portversion == 0} {
750        set x [glob -nocomplain [file join ${darwinports::registry.path} ${portname}-*]]
751        if {[string length $x]} {
752            set matchfile [lindex $x 0]
753        } else {
754            set matchfile ""
755        }
756    } else {
757        set matchfile [file join ${darwinports::registry.path} ${portname}-${portversion}]
758    }
759
760    # Might as well bail out early if no file to match
761    if {![string length $matchfile]} {
762        return ""
763    }
764
765    if {[file exists $matchfile]} {
766        return $matchfile
767    }
768    if {[file exists ${matchfile}.bz2]} {
769        return ${matchfile}.bz2
770    }
771    return ""
772}
773
774proc dportregistry::store {rhandle data} {
775    puts $rhandle $data
776}
777
778proc dportregistry::fetch {rhandle} {
779    return -1
780}
781
782proc dportregistry::traverse {func} {
783    return -1
784}
785
786proc dportregistry::close {rhandle} {
787    global _registry_name
788    global registry.nobzip
789
790    ::close $rhandle
791    system "mv ${_registry_name}.tmp ${_registry_name}"
792    if {[file exists ${_registry_name}] && [file exists /usr/bin/bzip2] && ![info exists registry.nobzip]} {
793        system "/usr/bin/bzip2 -f ${_registry_name}"
794    }
795}
796
797proc dportregistry::delete {portname {portversion 0}} {
798    global darwinports::registry.path
799
800    # regex match case, as in exists
801    if {$portversion == 0} {
802                set x [glob -nocomplain [file join ${darwinports::registry.path} ${portname}-*]]
803                if {[string length $x]} {
804                    exec rm -f [lindex $x 0]
805                }
806        } else {
807                # Remove the file (with or without .bz2 suffix)
808                set filename [file join ${darwinports::registry.path} ${portname}-${portversion}]
809                if { [file exists $filename] } {
810                        exec rm -rf $filename
811                } elseif { [file exists ${filename}.bz2] } {
812                        exec rm -rf ${filename}.bz2
813                }
814        }
815}
816
817proc dportregistry::fileinfo_for_file {fname} {
818    if {![catch {file stat $fname statvar}]} {
819        if {[file isfile $fname]} {
820            if {[catch {md5 file $fname} md5sum] == 0} {
821                # Create a line that matches md5(1)'s output
822                # for backwards compatibility
823                set line "MD5 ($fname) = $md5sum"
824                return [list $fname $statvar(uid) $statvar(gid) $statvar(mode) $statvar(size) $line]
825            }
826        } else {
827            return  [list $fname $statvar(uid) $statvar(gid) $statvar(mode) $statvar(size) "MD5 ($fname) NONE"]
828        }
829    }
830    return {}
831}
832
833proc dportregistry::fileinfo_for_entry {rval dir entry} {
834    upvar $rval myrval
835    set path [file join $dir $entry]
836    lappend myrval [dportregistry::fileinfo_for_file $path]
837    return $myrval
838}
839
840proc dportregistry::fileinfo_for_index {flist} {
841    global prefix
842
843    set rval {}
844    foreach file $flist {
845        if {[string match /* $file]} {
846            set fname $file
847            set dir /
848        } else {
849            set fname [file join $prefix $file]
850            set dir $prefix
851        }
852        dportregistry::fileinfo_for_entry rval $dir $file
853    }
854    return $rval
855}
856
857proc dportregistry::listinstalled {args} {
858    global darwinports::registry.path
859
860    set receiptglob [glob -nocomplain ${darwinports::registry.path}/*]
861
862    if {$receiptglob == ""} {
863        puts "No ports installed."
864    } else {
865        puts "The following ports are installed:"
866        foreach receipt $receiptglob {
867            if {[file extension $receipt] == ".bz2"} {
868                puts "\t[file rootname [file tail $receipt]]"
869            } else {
870                puts "\t[file tail $receipt]"
871            }
872        }
873    }
874}
875
Note: See TracBrowser for help on using the repository browser.