source: trunk/base/src/port1.0/portutil.tcl @ 3655

Last change on this file since 3655 was 3655, checked in by fkr, 15 years ago

Bug:
Submitted by:
Reviewed by:
Approved by:
Obtained from:

dmg target. Allows creation of dmg's that contains the pkg built via the 'package'-target.
discussions and ideas with landonf@ and wbb4@

  • Property svn:eol-style set to native
  • Property svn:executable set to *
File size: 28.6 KB
Line 
1# et:ts=4
2# portutil.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#
31
32package provide portutil 1.0
33package require Pextlib 1.0
34package require darwinports_dlist 1.0
35package require msgcat
36
37global targets target_uniqid all_variants
38
39set targets [list]
40set target_uniqid 0
41
42set all_variants [list]
43
44########### External High Level Procedures ###########
45
46
47# UI Instantiations
48foreach priority "debug info msg error warn" {
49    eval "proc ui_$priority {str} \{ \n\
50        set message(priority) $priority \n\
51        set message(data) \$str \n\
52        ui_event \[array get message\] \n\
53    \}"
54}
55
56
57namespace eval options {
58}
59
60# option
61# This is an accessor for Portfile options.  Targets may use
62# this in the same style as the standard Tcl "set" procedure.
63#       name  - the name of the option to read or write
64#       value - an optional value to assign to the option
65
66proc option {name args} {
67        # XXX: right now we just transparently use globals
68        # eventually this will need to bridge the options between
69        # the Portfile's interpreter and the target's interpreters.
70        global $name
71        if {[llength $args] > 0} {
72                ui_debug "setting option $name to $args"
73                set $name [lindex $args 0]
74        }
75        return [set $name]
76}
77
78# exists
79# This is an accessor for Portfile options.  Targets may use
80# this procedure to test for the existence of a Portfile option.
81#       name - the name of the option to test for existence
82
83proc exists {name} {
84        # XXX: right now we just transparently use globals
85        # eventually this will need to bridge the options between
86        # the Portfile's interpreter and the target's interpreters.
87        global $name
88        return [info exists $name]
89}
90
91# options
92# Exports options in an array as externally callable procedures
93# Thus, "options name date" would create procedures named "name"
94# and "date" that set global variables "name" and "date", respectively
95# When an option is modified in any way, options::$option is called,
96# if it exists
97# Arguments: <list of options>
98proc options {args} {
99    foreach option $args {
100        eval "proc $option {args} \{ \n\
101            global ${option} user_options option_procs \n\
102                \if \{!\[info exists user_options(${option})\]\} \{ \n\
103                     set ${option} \$args \n\
104                         if \{\[info exists option_procs($option)\]\} \{ \n\
105                                foreach p \$option_procs($option) \{ \n\
106                                        eval \"\$p $option set \$args\" \n\
107                                \} \n\
108                         \} \n\
109                \} \n\
110        \}"
111       
112        eval "proc ${option}-delete {args} \{ \n\
113            global ${option} user_options option_procs \n\
114                \if \{!\[info exists user_options(${option})\]\} \{ \n\
115                    foreach val \$args \{ \n\
116                        ldelete ${option} \$val \n\
117                    \} \n\
118                    if \{\[string length \$\{${option}\}\] == 0\} \{ \n\
119                        unset ${option} \n\
120                    \} \n\
121                        if \{\[info exists option_procs($option)\]\} \{ \n\
122                            foreach p \$option_procs($option) \{ \n\
123                                eval \"\$p $option delete \$args\" \n\
124                        \} \n\
125                    \} \n\
126                \} \n\
127        \}"
128        eval "proc ${option}-append {args} \{ \n\
129            global ${option} user_options option_procs \n\
130                \if \{!\[info exists user_options(${option})\]\} \{ \n\
131                    if \{\[info exists ${option}\]\} \{ \n\
132                        set ${option} \[concat \$\{$option\} \$args\] \n\
133                    \} else \{ \n\
134                        set ${option} \$args \n\
135                    \} \n\
136                    if \{\[info exists option_procs($option)\]\} \{ \n\
137                        foreach p \$option_procs($option) \{ \n\
138                            eval \"\$p $option append \$args\" \n\
139                        \} \n\
140                    \} \n\
141                \} \n\
142        \}"
143    }
144}
145
146proc options_export {args} {
147    foreach option $args {
148        eval "proc options::${option} \{args\} \{ \n\
149            global ${option} PortInfo \n\
150            if \{\[info exists ${option}\]\} \{ \n\
151                set PortInfo(${option}) \$${option} \n\
152            \} else \{ \n\
153                unset PortInfo(${option}) \n\
154            \} \n\
155        \}"
156        option_proc ${option} options::${option}
157    }
158}
159
160# option_deprecate
161# Causes a warning to be printed when an option is set or accessed
162proc option_deprecate {option {newoption ""} } {
163    # If a new option is specified, default the option to {${newoption}}
164    # Display a warning
165    if {$newoption != ""} {
166        eval "proc warn_deprecated_$option \{option action args\} \{ \n\
167            global portname $option $newoption \n\
168            if \{\$action != \"read\"\} \{ \n\
169                $newoption \$$option \n\
170            \} else \{ \n\
171                ui_warn \"Port \$portname using deprecated option \\\"$option\\\".\" \n\
172                $option \[set $newoption\] \n\
173            \} \n\
174        \}"
175    } else {
176        eval "proc warn_deprecated_$option \{option action args\} \{ \n\
177            global portname $option $newoption \n\
178            ui_warn \"Port \$portname using deprecated option \\\"$option\\\".\" \n\
179        \}"
180    }
181    option_proc $option warn_deprecated_$option
182}
183
184proc option_proc {option args} {
185    global option_procs $option
186    eval "lappend option_procs($option) $args"
187    # Add a read trace to the variable, as the option procedures have no access to reads
188    trace variable $option r option_proc_trace
189}
190
191# option_proc_trace
192# trace handler for option reads. Calls option procedures with correct arguments.
193proc option_proc_trace {optionName index op} {
194    global option_procs
195    foreach p $option_procs($optionName) {
196        eval "$p $optionName read"
197    }
198}
199
200# commands
201# Accepts a list of arguments, of which several options are created
202# and used to form a standard set of command options.
203proc commands {args} {
204    foreach option $args {
205        options use_${option} ${option}.dir ${option}.pre_args ${option}.args ${option}.post_args ${option}.env ${option}.type ${option}.cmd
206    }
207}
208
209# command
210# Given a command name, command assembled a string
211# composed of the command options.
212proc command {command} {
213    global ${command}.dir ${command}.pre_args ${command}.args ${command}.post_args ${command}.env ${command}.type ${command}.cmd
214   
215    set cmdstring ""
216    if {[info exists ${command}.dir]} {
217        set cmdstring "cd \"[set ${command}.dir]\" &&"
218    }
219   
220    if {[info exists ${command}.env]} {
221        foreach string [set ${command}.env] {
222            set cmdstring "$cmdstring $string"
223        }
224    }
225   
226    if {[info exists ${command}.cmd]} {
227        foreach string [set ${command}.cmd] {
228            set cmdstring "$cmdstring $string"
229        }
230    } else {
231        set cmdstring "$cmdstring ${command}"
232    }
233    foreach var "${command}.pre_args ${command}.args ${command}.post_args" {
234        if {[info exists $var]} {
235            foreach string [set ${var}] {
236                set cmdstring "$cmdstring $string"
237            }
238        }
239    }
240    ui_debug "Assembled command: '$cmdstring'"
241    return $cmdstring
242}
243
244# default
245# Sets a variable to the supplied default if it does not exist,
246# and adds a variable trace. The variable traces allows for delayed
247# variable and command expansion in the variable's default value.
248proc default {option val} {
249    global $option option_defaults
250    if {[info exists option_defaults($option)]} {
251        ui_debug "Re-registering default for $option"
252    } else {
253        # If option is already set and we did not set it
254        # do not reset the value
255        if {[info exists $option]} {
256            return
257        }
258    }
259    set option_defaults($option) $val
260    set $option $val
261    trace variable $option rwu default_check
262}
263
264# default_check
265# trace handler to provide delayed variable & command expansion
266# for default variable values
267proc default_check {optionName index op} {
268    global option_defaults $optionName
269    switch $op {
270        w {
271            unset option_defaults($optionName)
272            trace vdelete $optionName rwu default_check
273            return
274        }
275        r {
276            upvar $optionName option
277            uplevel #0 set $optionName $option_defaults($optionName)
278            return
279        }
280        u {
281            unset option_defaults($optionName)
282            trace vdelete $optionName rwu default_check
283            return
284        }
285    }
286}
287
288# variant <provides> [<provides> ...] [requires <requires> [<requires>]]
289# Portfile level procedure to provide support for declaring variants
290proc variant {args} {
291    global all_variants PortInfo
292    upvar $args upargs
293   
294    set len [llength $args]
295    set code [lindex $args end]
296    set args [lrange $args 0 [expr $len - 2]]
297   
298    set ditem [variant_new "temp-variant"]
299   
300    # mode indicates what the arg is interpreted as.
301        # possible mode keywords are: requires, conflicts, provides
302        # The default mode is provides.  Arguments are added to the
303        # most recently specified mode (left to right).
304    set mode "provides"
305    foreach arg $args {
306                switch -exact $arg {
307                        provides { set mode "provides" }
308                        requires { set mode "requires" }
309                        conflicts { set mode "conflicts" }
310                        default { ditem_append $ditem $mode $arg }             
311        }
312    }
313    ditem_key $ditem name "[join [ditem_key $ditem provides] -]"
314
315    # make a user procedure named variant-blah-blah
316    # we will call this procedure during variant-run
317    makeuserproc "variant-[ditem_key $ditem name]" \{$code\}
318    lappend all_variants $ditem
319   
320    # Export provided variant to PortInfo
321    lappend PortInfo(variants) [ditem_key $ditem provides]
322}
323
324# variant_isset name
325# Returns 1 if variant name selected, otherwise 0
326proc variant_isset {name} {
327    global variations
328   
329    if {[info exists variations($name)] && $variations($name) == "+"} {
330        return 1
331    }
332    return 0
333}
334
335# variant_set name
336# Sets variant to run for current portfile
337proc variant_set {name} {
338    global variations
339   
340    set variations($name) +
341}
342
343# variant_unset name
344# Clear variant for current portfile
345proc variant_unset {name} {
346    global variations
347
348    set variations($name) -
349}
350
351########### Misc Utility Functions ###########
352
353# tbool (testbool)
354# If the variable exists in the calling procedure's namespace
355# and is set to "yes", return 1. Otherwise, return 0
356proc tbool {key} {
357    upvar $key $key
358    if {[info exists $key]} {
359        if {[string equal -nocase [set $key] "yes"]} {
360            return 1
361        }
362    }
363    return 0
364}
365
366# ldelete
367# Deletes a value from the supplied list
368proc ldelete {list value} {
369    upvar $list uplist
370    set ix [lsearch -exact $uplist $value]
371    if {$ix >= 0} {
372        set uplist [lreplace $uplist $ix $ix]
373    }
374}
375
376# reinplace
377# Provides "sed in place" functionality
378proc reinplace {pattern args}  {
379    if {$args == ""} {
380        ui_error "reinplace: no value given for parameter \"file\""
381        return -code error "no value given for parameter \"file\" to \"reinplace\"" 
382    }
383
384    foreach file $args {
385        if {[catch {set tmpfile [mkstemp "/tmp/[file tail $file].sed.XXXXXXXX"]} error]} {
386            ui_error "reinplace: $error"
387            return -code error "reinplace failed"
388        } else {
389            # Extract the Tcl Channel number
390            set tmpfd [lindex $tmpfile 0]
391            # Set tmpfile to only the file name
392            set tmpfile [lindex $tmpfile 1]
393        }
394
395        if {[catch {exec sed $pattern < $file >@ $tmpfd} error]} {
396            ui_error "reinplace: $error"
397            file delete "$tmpfile"
398            return -code error "reinplace failed"
399        }
400
401        close $tmpfd
402
403        set attributes [file attributes $file]
404        # We need to overwrite this file
405        if {[catch {file attributes $file -permissions u+w} error]} {
406            ui_error "reinplace: $error"
407            file delete "$tmpfile"
408            return -code error "reinplace failed"
409        }
410
411        if {[catch {exec cp $tmpfile $file} error]} {
412            ui_error "reinplace: $error"
413            file delete "$tmpfile"
414            return -code error "reinplace failed"
415        }
416       
417        for {set i 0} {$i < [llength attributes]} {incr i} {
418            set opt [lindex $attributes $i]
419            incr i
420            set arg [lindex $attributes $i]
421            file attributes $file $opt $arg
422        }
423       
424        file delete "$tmpfile"
425    }
426    return
427}
428
429# filefindbypath
430# Provides searching of the standard path for included files
431proc filefindbypath {fname} {
432    global distpath filedir workdir worksrcdir portpath
433
434    if {[file readable $portpath/$fname]} {
435        return $portpath/$fname
436    } elseif {[file readable $portpath/$filedir/$fname]} {
437        return $portpath/$filedir/$fname
438    } elseif {[file readable $distpath/$fname]} {
439        return $distpath/$fname
440    }
441    return ""
442}
443
444# include
445# Source a file, looking for it along a standard search path.
446proc include {fname} {
447    set tgt [filefindbypath $fname]
448    if {[string length $tgt]} {
449        uplevel "source $tgt"
450    } else {
451        return -code error "Unable to find include file $fname"
452    }
453}
454
455# makeuserproc
456# This procedure re-writes the user-defined custom target to include
457# all the globals in its scope.  This is undeniably ugly, but I haven't
458# thought of any other way to do this.
459proc makeuserproc {name body} {
460    regsub -- "^\{(.*?)" $body "\{ \n foreach g \[info globals\] \{ \n global \$g \n \} \n \\1" body
461    eval "proc $name {} $body"
462}
463
464########### Internal Dependancy Manipulation Procedures ###########
465
466proc target_run {ditem} {
467    global target_state_fd portname
468    set result 0
469    set procedure [ditem_key $ditem procedure]
470    if {$procedure != ""} {
471        set name [ditem_key $ditem name]
472       
473        if {[ditem_contains $ditem init]} {
474            set result [catch {[ditem_key $ditem init] $name} errstr]
475        }
476       
477        if {[check_statefile target $name $target_state_fd] && $result == 0} {
478            set result 0
479            ui_debug "Skipping completed $name ($portname)"
480        } elseif {$result == 0} {
481            # Execute pre-run procedure
482            if {[ditem_contains $ditem prerun]} {
483                set result [catch {[ditem_key $ditem prerun] $name} errstr]
484            }
485           
486            if {$result == 0} {
487                foreach pre [ditem_key $ditem pre] {
488                    ui_debug "Executing $pre"
489                    set result [catch {$pre $name} errstr]
490                    if {$result != 0} { break }
491                }
492            }
493           
494            if {$result == 0} {
495                ui_debug "Executing $name ($portname)"
496                set result [catch {$procedure $name} errstr]
497            }
498           
499            if {$result == 0} {
500                foreach post [ditem_key $ditem post] {
501                    ui_debug "Executing $post"
502                    set result [catch {$post $name} errstr]
503                    if {$result != 0} { break }
504                }
505            }
506            # Execute post-run procedure
507            if {[ditem_contains $ditem postrun] && $result == 0} {
508                set postrun [ditem_key $ditem postrun]
509                ui_debug "Executing $postrun"
510                set result [catch {$postrun $name} errstr]
511            }
512        }
513        if {$result == 0} {
514            if {[ditem_key $ditem runtype] != "always"} {
515                write_statefile target $name $target_state_fd
516            }
517        } else {
518            ui_error "Target $name returned: $errstr"
519            set result 1
520        }
521       
522    } else {
523        ui_info "Warning: $name does not have a registered procedure"
524        set result 1
525    }
526   
527    return $result
528}
529
530proc eval_targets {target} {
531    global targets target_state_fd portname
532    set dlist $targets
533           
534        # Select the subset of targets under $target
535    if {$target != ""} {
536        set matches [dlist_search $dlist provides $target]
537
538        if {[llength $matches] > 0} {
539                        set dlist [dlist_append_dependents $dlist [lindex $matches 0] [list]]
540                        # Special-case 'all'
541                } elseif {$target != "all"} {
542                        ui_error "unknown target: $target"
543            return 1
544        }
545    }
546       
547    # Restore the state from a previous run.
548    set target_state_fd [open_statefile]
549   
550    set dlist [dlist_eval $dlist "" target_run]
551
552    if {[llength $dlist] > 0} {
553                # somebody broke!
554                set errstring "Warning: the following items did not execute (for $portname):"
555                foreach ditem $dlist {
556                        append errstring " [ditem_key $ditem name]"
557                }
558                ui_info $errstring
559                set result 1
560    } else {
561                set result 0
562    }
563       
564    close $target_state_fd
565    return $result
566}
567
568# open_statefile
569# open file to store name of completed targets
570proc open_statefile {args} {
571    global workpath portname portpath ports_ignore_older
572   
573    if {![file isdirectory $workpath]} {
574        file mkdir $workpath
575    }
576    # flock Portfile
577    set statefile [file join $workpath .darwinports.${portname}.state]
578    if {[file exists $statefile]} {
579                if {![file writable $statefile]} {
580                        return -code error "$statefile is not writable - check permission on port directory"
581                }
582                if {!([info exists ports_ignore_older] && $ports_ignore_older == "yes") && [file mtime $statefile] < [file mtime ${portpath}/Portfile]} {
583                        ui_msg "Portfile changed since last build; discarding previous state."
584                        #file delete $statefile
585                        exec rm -rf [file join $workpath]
586                        exec mkdir [file join $workpath]
587                }
588        }
589       
590    set fd [open $statefile a+]
591    if {[catch {flock $fd -exclusive -noblock} result]} {
592        if {"$result" == "EAGAIN"} {
593            ui_msg "Waiting for lock on $statefile"
594        } elseif {"$result" == "EOPNOTSUPP"} {
595            # Locking not supported, just return
596            return $fd
597        } else {
598            return -code error "$result obtaining lock on $statefile"
599        }
600    }
601    flock $fd -exclusive
602    return $fd
603}
604
605# check_statefile
606# Check completed/selected state of target/variant $name
607proc check_statefile {class name fd} {
608    global portpath workdir
609       
610    seek $fd 0
611    while {[gets $fd line] >= 0} {
612                if {$line == "$class: $name"} {
613                        return 1
614                }
615    }
616    return 0
617}
618
619# write_statefile
620# Set target $name completed in the state file
621proc write_statefile {class name fd} {
622    if {[check_statefile $class $name $fd]} {
623                return 0
624    }
625    seek $fd 0 end
626    puts $fd "$class: $name"
627    flush $fd
628}
629
630# check_statefile_variants
631# Check that recorded selection of variants match the current selection
632proc check_statefile_variants {variations fd} {
633        upvar $variations upvariations
634       
635    seek $fd 0
636    while {[gets $fd line] >= 0} {
637                if {[regexp "variant: (.*)" $line match name]} {
638                        set oldvariations([string range $name 1 end]) [string range $name 0 0]
639                }
640    }
641
642        set mismatch 0
643        if {[array size oldvariations] > 0} {
644                if {[array size oldvariations] != [array size upvariations]} {
645                        set mismatch 1
646                } else {
647                        foreach key [array names upvariations *] {
648                                if {$upvariations($key) != $oldvariations($key)} {
649                                        set mismatch 1
650                                        break
651                                }
652                        }
653                }
654        }
655
656        return $mismatch
657}
658
659# Traverse the ports collection hierarchy and call procedure func for
660# each directory containing a Portfile
661proc port_traverse {func {dir .}} {
662    set pwd [pwd]
663    if {[catch {cd $dir} err]} {
664        ui_error $err
665        return
666    }
667    foreach name [readdir .] {
668        if {[string match $name .] || [string match $name ..]} {
669            continue
670        }
671        if {[file isdirectory $name]} {
672            port_traverse $func $name
673        } else {
674            if {[string match $name Portfile]} {
675                catch {eval $func {[file join $pwd $dir]}}
676            }
677        }
678    }
679    cd $pwd
680}
681
682
683########### Port Variants ###########
684
685# Each variant which provides a subset of the requested variations
686# will be chosen.  Returns a list of the selected variants.
687proc choose_variants {dlist variations} {
688    upvar $variations upvariations
689   
690    set selected [list]
691   
692    foreach ditem $dlist {
693        # Enumerate through the provides, tallying the pros and cons.
694        set pros 0
695        set cons 0
696        set ignored 0
697        foreach flavor [ditem_key $ditem provides] {
698            if {[info exists upvariations($flavor)]} {
699                if {$upvariations($flavor) == "+"} {
700                    incr pros
701                } elseif {$upvariations($flavor) == "-"} {
702                    incr cons
703                }
704            } else {
705                incr ignored
706            }
707        }
708       
709        if {$cons > 0} { continue }
710       
711        if {$pros > 0 && $ignored == 0} {
712            lappend selected $ditem
713        }
714    }
715    return $selected
716}
717
718proc variant_run {ditem} {
719    set name [ditem_key $ditem name]
720    ui_debug "Executing $name provides [ditem_key $ditem provides]"
721
722        # test for conflicting variants
723        foreach v [ditem_key $ditem conflicts] {
724                if {[variant_isset $v]} {
725                        ui_error "Variant $name conflicts with $v"
726                        return 1
727                }
728        }
729
730    # execute proc with same name as variant.
731    if {[catch "variant-${name}" result]} {
732        ui_error "Error executing $name: $result"
733        return 1
734    }
735    return 0
736}
737
738proc eval_variants {variations target} {
739    global all_variants ports_force
740    set dlist $all_variants
741        set result 0
742    upvar $variations upvariations
743    set chosen [choose_variants $dlist upvariations]
744   
745    # now that we've selected variants, change all provides [a b c] to [a-b-c]
746    # this will eliminate ambiguity between item a, b, and a-b while fulfilling requirments.
747    #foreach obj $dlist {
748    #    $obj set provides [list [join [$obj get provides] -]]
749    #}
750   
751    set newlist [list]
752    foreach variant $chosen {
753        set newlist [dlist_append_dependents $dlist $variant $newlist]
754    }
755   
756    dlist_eval $newlist "" variant_run
757       
758        # Make sure the variations match those stored in the statefile.
759        # If they don't match, print an error indicating a 'port clean'
760        # should be performed. 
761        # - Skip this test if the statefile is empty.
762        # - Skip this test if performing a clean.
763        # - Skip this test if ports_force was specified.
764
765        if {$target != "clean" && 
766                !([info exists ports_force] && $ports_force == "yes")} {
767                set state_fd [open_statefile]
768       
769                if {[check_statefile_variants upvariations $state_fd]} {
770                        ui_error "Requested variants do not match original selection.\nPlease perform 'port clean' or specify the force option."
771                        set result 1
772                } else {
773                        # Write variations out to the statefile
774                        foreach key [array names upvariations *] {
775                                write_statefile variant $upvariations($key)$key $state_fd
776                        }
777                }
778               
779                close $state_fd
780        }
781       
782        return $result
783}
784
785# Target class definition.
786
787# constructor for target object
788proc target_new {name procedure} {
789    global targets
790    set ditem [ditem_create]
791       
792        ditem_key $ditem name $name
793        ditem_key $ditem procedure $procedure
794   
795    lappend targets $ditem
796   
797    return $ditem
798}
799
800proc target_provides {ditem args} {
801    global targets
802    # Register the pre-/post- hooks for use in Portfile.
803    # Portfile syntax: pre-fetch { puts "hello world" }
804    # User-code exceptions are caught and returned as a result of the target.
805    # Thus if the user code breaks, dependent targets will not execute.
806    foreach target $args {
807        set origproc [ditem_key $ditem procedure]
808        set ident [ditem_key $ditem name]
809        if {[info commands $target] != ""} {
810            ui_debug "$ident registered provides \'$target\', a pre-existing procedure. Target override will not be provided"
811        } else {
812                eval "proc $target {args} \{ \n\
813                        ditem_key $ditem procedure proc-${ident}-${target}
814                        eval \"proc proc-${ident}-${target} \{name\} \{ \n\
815                                if \{\\\[catch userproc-${ident}-${target} result\\\]\} \{ \n\
816                                        return -code error \\\$result \n\
817                                \} else \{ \n\
818                                        return 0 \n\
819                                \} \n\
820                        \}\" \n\
821                        eval \"proc do-$target \{\} \{ $origproc $target\}\" \n\
822                        makeuserproc userproc-${ident}-${target} \$args \n\
823                \}"
824        }
825        eval "proc pre-$target {args} \{ \n\
826                        ditem_append $ditem pre proc-pre-${ident}-${target}
827                        eval \"proc proc-pre-${ident}-${target} \{name\} \{ \n\
828                                if \{\\\[catch userproc-pre-${ident}-${target} result\\\]\} \{ \n\
829                                        return -code error \\\$result \n\
830                                \} else \{ \n\
831                                        return 0 \n\
832                                \} \n\
833                        \}\" \n\
834                        makeuserproc userproc-pre-${ident}-${target} \$args \n\
835                \}"
836        eval "proc post-$target {args} \{ \n\
837                        ditem_append $ditem post proc-post-${ident}-${target}
838                        eval \"proc proc-post-${ident}-${target} \{name\} \{ \n\
839                                if \{\\\[catch userproc-post-${ident}-${target} result\\\]\} \{ \n\
840                                        return -code error \\\$result \n\
841                                \} else \{ \n\
842                                        return 0 \n\
843                                \} \n\
844                        \}\" \n\
845                        makeuserproc userproc-post-${ident}-${target} \$args \n\
846                \}"
847    }
848    eval "ditem_append $ditem provides $args"
849}
850
851proc target_requires {ditem args} {
852    eval "ditem_append $ditem requires $args"
853}
854
855proc target_uses {ditem args} {
856    eval "ditem_append $ditem uses $args"
857}
858
859proc target_deplist {ditem args} {
860    eval "ditem_append $ditem deplist $args"
861}
862
863proc target_prerun {ditem args} {
864    eval "ditem_append $ditem prerun $args"
865}
866
867proc target_postrun {ditem args} {
868    eval "ditem_append $ditem postrun $args"
869}
870
871proc target_runtype {ditem args} {
872        eval "ditem_append $ditem runtype $args"
873}
874
875proc target_init {ditem args} {
876    eval "ditem_append $ditem init $args"
877}
878
879##### variant class #####
880
881# constructor for variant objects
882proc variant_new {name} {
883    set ditem [ditem_create]
884    ditem_key $ditem name $name
885    return $ditem
886}
887
888proc handle_default_variants {option action args} {
889    global variations
890    switch -regex $action {
891        set|append {
892            foreach v $args {
893                if {[regexp {([-+])([-A-Za-z0-9_]+)} $v whole val variant]} {
894                    if {![info exists variations($variant)]} {
895                        set variations($variant) $val
896                    }
897                }
898            }
899        }
900        delete {
901            # xxx
902        }
903    }
904}
905
906
907# builds the specified port (looked up in the index) to the specified target
908# doesn't yet support options or variants...
909# newworkpath defines the port's workpath - useful for when one port relies
910# on the source, etc, of another
911proc portexec_int {portname target {newworkpath ""}} {
912    ui_debug "Executing $target ($portname)"
913    set variations [list]
914    if {$newworkpath == ""} {
915        array set options [list]
916    } else {
917        set options(workpath) ${newworkpath}
918    }
919        # Escape regex special characters
920        regsub -all "(\\(){1}|(\\)){1}|(\\{1}){1}|(\\+){1}|(\\{1}){1}|(\\{){1}|(\\}){1}|(\\^){1}|(\\$){1}|(\\.){1}|(\\\\){1}" $portname "\\\\&" search_string
921
922    set res [dportsearch ^$search_string\$]
923    if {[llength $res] < 2} {
924        ui_error "Dependency $portname not found"
925        return -1
926    }
927
928    array set portinfo [lindex $res 1]
929    set porturl $portinfo(porturl)
930    if {[catch {set worker [dportopen $porturl [array get options] $variations]} result]} {
931        ui_error "Opening $portname $target failed: $result"
932        return -1
933    }
934    if {[catch {dportexec $worker $target} result] || $result != 0} {
935        ui_error "Execution $portname $target failed: $result"
936        dportclose $worker
937        return -1
938    }
939    dportclose $worker
940   
941    return 0
942}
943
944# portfile primitive that calls portexec_int with newworkpath == ${workpath}
945proc portexec {portname target} {
946    global workpath
947    return [portexec_int $portname $target $workpath]
948}
949
950proc adduser {name args} {
951    global os.platform
952    set passwd {\*}
953    set uid [nextuid]
954    set gid [existsgroup nogroup]
955    set realname ${name}
956    set home /dev/null
957    set shell /dev/null
958
959    foreach arg $args {
960        if {[regexp {([a-z]*)=(.*)} $arg match key val]} {
961            regsub -all " " ${val} "\\ " val
962            set $key $val
963        }
964    }
965
966    if {[existsuser ${name}] != 0 || [existsuser ${uid}] != 0} {
967        return
968    }
969
970    if {${os.platform} == "darwin"} {
971        system "niutil -create . /users/${name}"
972        system "niutil -createprop . /users/${name} name ${name}"
973        system "niutil -createprop . /users/${name} passwd ${passwd}"
974        system "niutil -createprop . /users/${name} uid ${uid}"
975        system "niutil -createprop . /users/${name} gid ${gid}"
976        system "niutil -createprop . /users/${name} realname ${realname}"
977        system "niutil -createprop . /users/${name} home ${home}"
978        system "niutil -createprop . /users/${name} shell ${shell}"
979    } else {
980        # XXX adduser is only available for darwin, add more support here
981        ui_warn "WARNING: adduser is not implemented on ${os.platform}."
982        ui_warn "The requested user was not created."
983    }
984}
985
986proc addgroup {name args} {
987    global os.platform
988    set gid [nextgid]
989    set passwd {\*}
990    set users ""
991
992    foreach arg $args {
993        if {[regexp {([a-z]*)=(.*)} $arg match key val]} {
994            regsub -all " " ${val} "\\ " val
995            set $key $val
996        }
997    }
998
999    if {[existsgroup ${name}] != 0 || [existsgroup ${gid}] != 0} {
1000        return
1001    }
1002
1003    if {${os.platform} == "darwin"} {
1004        system "niutil -create . /groups/${name}"
1005        system "niutil -createprop . /groups/${name} name ${name}"
1006        system "niutil -createprop . /groups/${name} gid ${gid}"
1007        system "niutil -createprop . /groups/${name} passwd ${passwd}"
1008        system "niutil -createprop . /groups/${name} users ${users}"
1009    } else {
1010        # XXX addgroup is only available for darwin, add more support here
1011        ui_warn "WARNING: addgroup is not implemented on ${os.platform}."
1012        ui_warn "The requested group was not created."
1013    }
1014}
1015
1016# proc to calculate size of a directory
1017# moved here from portpackage.tcl
1018proc dirSize {dir} {
1019    set size    0;
1020    foreach file [readdir $dir] {
1021        if {$file == "." || $file == ".." || [file type [file join $dir $file]] == "link" } {
1022            continue
1023        }
1024        if {[file isdirectory [file join $dir $file]]} {
1025            incr size [dirSize [file join $dir $file]]
1026        } else {
1027            incr size [file size [file join $dir $file]];
1028        }
1029    }
1030    return $size;
1031}
Note: See TracBrowser for help on using the repository browser.