source: trunk/base/src/port/port.tcl @ 4477

Last change on this file since 4477 was 4477, checked in by jkh, 17 years ago

This is a basically rewritten port(1) contents target. Summary of changes:

  • Read the file in one line at a time, rather than all at once.
  • Use regexp to match each line on {contents \{(.*)\}$}, ensuring that only

the actual contents information will be matched.

  • Move file-close check to the end of the target.
  • Formatting fixes - stupid tabs!

These changes should be entirely transparent - it behaves exactly as it did
before.

Bug: 1252
Submitted by: Toby Peterson <tp62@…>

  • Property svn:eol-style set to native
  • Property svn:executable set to *
File size: 10.6 KB
Line 
1#!@TCLSH@
2# port.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 require darwinports
32
33# globals
34set portdir .
35
36# UI Instantiations
37# ui_options(ports_debug) - If set, output debugging messages.
38# ui_options(ports_verbose) - If set, output info messages (ui_info)
39# ui_options(ports_quiet) - If set, don't output "standard messages"
40
41# ui_options accessor
42proc ui_isset {val} {
43    global ui_options
44    if {[info exists ui_options($val)]} {
45        if {$ui_options($val) == "yes"} {
46            return 1
47        }
48    }
49    return 0
50}
51
52# UI Callback
53
54proc ui_puts {messagelist} {
55    set channel stdout
56    array set message $messagelist
57    switch $message(priority) {
58        debug {
59            if {[ui_isset ports_debug]} {
60                set channel stderr
61                set str "DEBUG: $message(data)"
62            } else {
63                return
64            }
65        }
66        info {
67            if {![ui_isset ports_verbose]} {
68                return
69            }
70            set str $message(data)
71        }
72        msg {
73            if {[ui_isset ports_quiet]} {
74                return
75            }
76            set str $message(data)
77        }
78        error {
79            set str "Error: $message(data)"
80            set channel stderr
81        }
82        warn {
83            set str "Warning: $message(data)"
84        }
85    }
86    puts $channel $str
87}
88
89# Standard procedures
90proc print_usage args {
91    global argv0
92    puts "Usage: $argv0 \[-vdqof\] \[action\] \[-D portdir\] \[options\]"
93}
94
95proc fatal args {
96    global argv0
97    puts stderr "$argv0: $args"
98    exit
99}
100
101# Main
102set separator 0
103array set options [list]
104array set variations [list]
105for {set i 0} {$i < $argc} {incr i} {
106    set arg [lindex $argv $i]
107   
108    # if -xyz before the separator
109    if {$separator == 0 && [regexp {^-([-A-Za-z0-9]+)$} $arg match opt] == 1} {
110        if {$opt == "-"} {
111            set separator 1
112        } else {
113            foreach c [split $opt {}] {
114                if {$c == "v"} {
115                    set ui_options(ports_verbose) yes
116                } elseif {$c == "f"} {
117                    set options(ports_force) yes
118                } elseif {$c == "d"} {
119                    set ui_options(ports_debug) yes
120                    # debug infers verbose
121                    set ui_options(ports_verbose) yes
122                } elseif {$c == "q"} {
123                    set ui_options(ports_quiet) yes
124                    set ui_options(ports_verbose) no
125                    set ui_options(ports_debug) no
126                } elseif {$c == "o"} {
127                    set options(ports_ignore_older) yes
128                } elseif {$opt == "D"} {
129                    incr i
130                    set porturl "file://[lindex $argv $i]"
131                } elseif {$opt == "u"} {
132                    incr i
133                    set porturl [lindex $argv $i]
134                } else {
135                    print_usage; exit
136                }
137            }
138        }
139       
140        # if +xyz -xyz or after the separator
141    } elseif {[regexp {^([-+])([-A-Za-z0-9_+\.]+)$} $arg match sign opt] == 1} {
142        set variations($opt) $sign
143       
144        # option=value
145    } elseif {[regexp {([A-Za-z0-9_\.]+)=(.*)} $arg match key val] == 1} {
146        set options($key) \"$val\"
147       
148        # action
149    } elseif {[regexp {^([A-Za-z0-9/._\-^$ \[\[?\(\)\\|\+\*]+)$} $arg match opt] == 1} {
150        if {[info exists action]} {
151            set portname $opt
152        } else {
153            set action $opt
154        }
155    } else {
156        print_usage; exit
157    }
158}
159
160if {![info exists action]} {
161    set action build
162}
163
164if {$action == "list"} {
165    set action search
166    set portname .+
167}
168
169if {[catch {dportinit} result]} {
170    puts "Failed to initialize ports system, $result"
171    exit 1
172}
173
174switch -- $action {
175    deps {
176        set nodeps true
177
178        # make sure a port was given on the command line
179        if {![info exists portname]} {
180            puts "You must specify a port"
181            exit 1
182        }
183
184        # search for port
185        if {[catch {dportsearch ^$portname$} result]} {
186            puts "port search failed: $result"
187            exit 1
188        }
189
190        if {$result == ""} {
191            puts "No port $portname found."
192            exit 1
193        }
194
195        array set portinfo [lindex $result 1]
196
197        # find build dependencies
198        if {[info exists portinfo(depends_build)]} {
199            puts "$portname has build dependencies on:"
200            foreach i $portinfo(depends_build) {
201                puts "\t[lindex [split [lindex $i 0] :] 2]"
202            }
203            set nodeps false
204        }
205
206        # find library dependencies
207        if {[info exists portinfo(depends_lib)]} {
208            puts "$portname has library dependencies on:"
209            foreach i $portinfo(depends_lib) {
210                puts "\t[lindex [split [lindex $i 0] :] 2]"
211            }
212            set nodeps false
213        }
214
215        # find runtime dependencies
216        if {[info exists portinfo(depends_run)]} {
217            puts "$portname has runtime dependencies on:"
218            foreach i $portinfo(depends_run) {
219                puts "\t[lindex [split [lindex $i 0] :] 2]"
220            }
221            set nodeps false
222        }
223
224        # no dependencies found
225        if {$nodeps == "true"} {
226            puts "$portname has no dependencies"
227        }
228    }
229    installed {
230        if {[catch {dportregistry::listinstalled} result]} {
231            puts "Port failed: $result"
232            exit 1
233        }
234    }
235    variants {
236        # make sure a port was given on the command line
237        if {![info exists portname]} {
238            puts "You must specify a port"
239            exit 1
240        }
241       
242        # search for port
243        if {[catch {dportsearch ^$portname$} result]} {
244            puts "port search failed: $result"
245            exit 1
246        }
247       
248        if {$result == ""} {
249            puts "No port $portname found."
250        }
251       
252        array set portinfo [lindex $result 1]
253       
254        # if this fails the port doesn't have any variants
255        if {![info exists portinfo(variants)]} {
256            puts "$portname has no variants"
257        } else {
258            # print out all the variants
259            for {set i 0} {$i < [llength $portinfo(variants)]} {incr i} {
260                puts "[lindex $portinfo(variants) $i]"
261            }
262        }
263    }
264    contents {
265        # make sure a port was given on the command line
266        if {![info exists portname]} {
267            puts "You must specify a port"
268            exit 1
269        }
270       
271        set rfile [dportregistry::exists $portname]
272        if {$rfile != ""} {
273            if {[file extension $rfile] == ".bz2"} {
274                set shortname [file rootname [file tail $rfile]]
275                set fd [open "|bzcat -q $rfile" r]
276            } else {
277                set shortname [file tail $rfile]
278                set fd [open $rfile r]
279            }
280           
281            while {-1 < [gets $fd line]} {
282                set match [regexp {^contents \{(.*)\}$} $line dummy contents]
283                if {$match == 1} {
284                    puts "Contents of $shortname"
285                    foreach f $contents {
286                        puts "\t[lindex $f 0]"
287                    }
288                    break
289                }
290            }
291           
292            if {$match == 0} {
293                puts "No contents list for $shortname"
294                exit 1
295            }
296           
297            # kind of a corner case but I ran into it testing
298            if {[catch {close $fd} result]} {
299                puts "Port failed: $rfile may be corrupted"
300                exit 1
301            }
302        } else {
303            puts "Contents listing failed - no registry entry"
304            exit 1
305        }
306    }
307    search {
308        if {![info exists portname]} {
309            puts "You must specify a search pattern"
310            exit 1
311        }
312        if {[catch {set res [dportsearch $portname]} result]} {
313            puts "port search failed: $result"
314            exit 1
315        }
316        foreach {name array} $res {
317            array set portinfo $array
318           
319            # XXX is this the right place to verify an entry?
320            if {![info exists portinfo(name)]} {
321                puts "Invalid port entry, missing portname"
322                continue
323            }
324            if {![info exists portinfo(description)]} {
325                puts "Invalid port entry for $portinfo(name), missing description"
326                continue
327            }
328            if {![info exists portinfo(version)]} {
329                puts "Invalid port entry for $portinfo(name), missing version"
330                continue
331            }
332            if {![info exists portinfo(portdir)]} {
333                set output [format "%-20s\t%-8s\t%s" $portinfo(name) $portinfo(version) $portinfo(description)]
334            } else {
335                set output [format "%-8s\t%-14s\t%-8s\t%s" $portinfo(name) $portinfo(portdir) $portinfo(version) $portinfo(description)]
336            }
337            set portfound 1
338            puts $output
339            unset portinfo
340        }
341        if {![info exists portfound] || $portfound == 0} {
342            puts "No match for $portname found"
343            exit 1
344        }
345    }
346    sync {
347        if {[catch {dportsync} result]} {
348            puts "port sync failed: $result"
349            exit 1
350        }
351    }
352    default {
353        set target $action
354        if {[info exists portname]} {
355            # Escape regex special characters
356            regsub -all "(\\(){1}|(\\)){1}|(\\{1}){1}|(\\+){1}|(\\{1}){1}|(\\{){1}|(\\}){1}|(\\^){1}|(\\$){1}|(\\.){1}|(\\\\){1}" $portname "\\\\&" search_string
357            if {[catch {set res [dportsearch ^$search_string\$]} result]} {
358                puts "port search failed: $result"
359                exit 1
360            }
361            if {[llength $res] < 2} {
362                puts "Port $portname not found"
363                exit 1
364            }
365            array set portinfo [lindex $res 1]
366            set porturl $portinfo(porturl)
367        }
368        if {![info exists porturl]} {
369            set porturl file://./
370        }
371        if {[catch {set workername [dportopen $porturl [array get options] [array get variations]]} result]} {
372            puts "Unable to open port: $result"
373            exit 1
374        }
375        if {[catch {set result [dportexec $workername $target]} result]} {
376            puts "Unable to execute port: $result"
377            exit 1
378        }
379       
380        dportclose $workername
381        exit $result
382    }
383}
Note: See TracBrowser for help on using the repository browser.