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

Last change on this file since 2426 was 2426, checked in by landonf (Landon Fuller), 18 years ago

Allow DarwinPorts to build out of the box on newer Darwin releases with Tcl 8.4

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