Ticket #1385: darwinports.tcl

File darwinports.tcl, 24.7 KB (added by tp62@…, 21 years ago)

Patch for darwinports/base/src/darwinports1.0/darwinports.tcl

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