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

Last change on this file since 2358 was 2358, checked in by kevin, 18 years ago

eval variants while fulfilling dependencies.

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