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

Last change on this file since 13528 was 13528, checked in by pguyot, 12 years ago

I'm fed up with all these global variables.

  • Property svn:eol-style set to native
  • Property svn:executable set to *
File size: 37.3 KB
Line 
1# et:ts=4
2# portutil.tcl
3#
4# Copyright (c) 2004 Robert Shaw <rshaw@opendarwin.org>
5# Copyright (c) 2002 Apple Computer, Inc.
6# All rights reserved.
7#
8# Redistribution and use in source and binary forms, with or without
9# modification, are permitted provided that the following conditions
10# are met:
11# 1. Redistributions of source code must retain the above copyright
12#    notice, this list of conditions and the following disclaimer.
13# 2. Redistributions in binary form must reproduce the above copyright
14#    notice, this list of conditions and the following disclaimer in the
15#    documentation and/or other materials provided with the distribution.
16# 3. Neither the name of Apple Computer, Inc. nor the names of its contributors
17#    may be used to endorse or promote products derived from this software
18#    without specific prior written permission.
19#
20# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
21# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
22# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
23# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
24# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
25# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
26# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
27# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
28# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
29# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
30# POSSIBILITY OF SUCH DAMAGE.
31#
32
33package provide portutil 1.0
34package require Pextlib 1.0
35package require darwinports_dlist 1.0
36package require msgcat
37package require porttrace 1.0
38package require darwinports 1.0
39
40global targets target_uniqid all_variants
41
42set targets [list]
43set target_uniqid 0
44
45set all_variants [list]
46
47########### External High Level Procedures ###########
48
49namespace eval options {
50}
51
52# option
53# This is an accessor for Portfile options.  Targets may use
54# this in the same style as the standard Tcl "set" procedure.
55#       name  - the name of the option to read or write
56#       value - an optional value to assign to the option
57
58proc option {name args} {
59    # XXX: right now we just transparently use globals
60    # eventually this will need to bridge the options between
61    # the Portfile's interpreter and the target's interpreters.
62    global $name
63    if {[llength $args] > 0} {
64        ui_debug "setting option $name to $args"
65        set $name [lindex $args 0]
66    }
67    return [set $name]
68}
69
70# exists
71# This is an accessor for Portfile options.  Targets may use
72# this procedure to test for the existence of a Portfile option.
73#       name - the name of the option to test for existence
74
75proc exists {name} {
76    # XXX: right now we just transparently use globals
77    # eventually this will need to bridge the options between
78    # the Portfile's interpreter and the target's interpreters.
79    global $name
80    return [info exists $name]
81}
82
83# options
84# Exports options in an array as externally callable procedures
85# Thus, "options name date" would create procedures named "name"
86# and "date" that set global variables "name" and "date", respectively
87# When an option is modified in any way, options::$option is called,
88# if it exists
89# Arguments: <list of options>
90proc options {args} {
91    foreach option $args {
92        eval "proc $option {args} \{ \n\
93            global ${option} user_options option_procs \n\
94                \if \{!\[info exists user_options(${option})\]\} \{ \n\
95                     set ${option} \$args \n\
96                \} \n\
97        \}"
98       
99        eval "proc ${option}-delete {args} \{ \n\
100            global ${option} user_options option_procs \n\
101                \if \{!\[info exists user_options(${option})\]\ && \[info exists ${option}\]\} \{ \n\
102                    foreach val \$args \{ \n\
103                       set ${option} \[ldelete \$\{$option\} \$val\] \n\
104                    \} \n\
105                    if \{\[string length \$\{${option}\}\] == 0\} \{ \n\
106                        unset ${option} \n\
107                    \} \n\
108                \} \n\
109        \}"
110        eval "proc ${option}-append {args} \{ \n\
111            global ${option} user_options option_procs \n\
112                \if \{!\[info exists user_options(${option})\]\} \{ \n\
113                    if \{\[info exists ${option}\]\} \{ \n\
114                        set ${option} \[concat \$\{$option\} \$args\] \n\
115                    \} else \{ \n\
116                        set ${option} \$args \n\
117                    \} \n\
118                \} \n\
119        \}"
120    }
121}
122
123proc options_export {args} {
124    foreach option $args {
125        eval "proc options::export-${option} \{args\} \{ \n\
126            global ${option} PortInfo \n\
127            if \{\[info exists ${option}\]\} \{ \n\
128                set PortInfo(${option}) \$\{${option}\} \n\
129            \} else \{ \n\
130                unset PortInfo(${option}) \n\
131            \} \n\
132        \}"
133        option_proc ${option} options::export-${option}
134    }
135}
136
137# option_deprecate
138# Causes a warning to be printed when an option is set or accessed
139proc option_deprecate {option {newoption ""} } {
140    # If a new option is specified, default the option to {${newoption}}
141    # Display a warning
142    if {$newoption != ""} {
143        eval "proc warn_deprecated_$option \{option action args\} \{ \n\
144            global portname $option $newoption \n\
145            if \{\$action != \"read\"\} \{ \n\
146                $newoption \$$option \n\
147            \} else \{ \n\
148                ui_warn \"Port \$portname using deprecated option \\\"$option\\\".\" \n\
149                $option \[set $newoption\] \n\
150            \} \n\
151        \}"
152    } else {
153        eval "proc warn_deprecated_$option \{option action args\} \{ \n\
154            global portname $option $newoption \n\
155            ui_warn \"Port \$portname using deprecated option \\\"$option\\\".\" \n\
156        \}"
157    }
158    option_proc $option warn_deprecated_$option
159}
160
161proc option_proc {option args} {
162    global option_procs $option
163    eval "lappend option_procs($option) $args"
164    # Add a read trace to the variable, as the option procedures have no access to reads
165    trace variable $option rwu option_proc_trace
166}
167
168# option_proc_trace
169# trace handler for option reads. Calls option procedures with correct arguments.
170proc option_proc_trace {optionName index op} {
171    global option_procs
172    upvar $optionName optionValue
173    switch $op {
174        w {
175            foreach p $option_procs($optionName) {
176                eval "$p $optionName set ${optionValue}" 
177            }
178            return
179        }
180        r {
181            foreach p $option_procs($optionName) {
182                eval "$p $optionName read"
183            }
184            return
185        }
186        u {
187            foreach p $option_procs($optionName) {
188                eval "$p $optionName delete"
189                trace vdelete $optionName rwu $p
190            }
191            return
192        }
193    }
194}
195
196# commands
197# Accepts a list of arguments, of which several options are created
198# and used to form a standard set of command options.
199proc commands {args} {
200    foreach option $args {
201        options use_${option} ${option}.dir ${option}.pre_args ${option}.args ${option}.post_args ${option}.env ${option}.type ${option}.cmd
202    }
203}
204
205# command
206# Given a command name, command assembled a string
207# composed of the command options.
208proc command {command} {
209    global ${command}.dir ${command}.pre_args ${command}.args ${command}.post_args ${command}.env ${command}.type ${command}.cmd
210   
211    set cmdstring ""
212    if {[info exists ${command}.dir]} {
213        set cmdstring "cd \"[set ${command}.dir]\" &&"
214    }
215   
216    if {[info exists ${command}.env]} {
217        foreach string [set ${command}.env] {
218            set cmdstring "$cmdstring $string"
219        }
220    }
221   
222    if {[info exists ${command}.cmd]} {
223        foreach string [set ${command}.cmd] {
224            set cmdstring "$cmdstring $string"
225        }
226    } else {
227        set cmdstring "$cmdstring ${command}"
228    }
229    foreach var "${command}.pre_args ${command}.args ${command}.post_args" {
230        if {[info exists $var]} {
231            foreach string [set ${var}] {
232                set cmdstring "$cmdstring $string"
233            }
234        }
235    }
236    ui_debug "Assembled command: '$cmdstring'"
237    return $cmdstring
238}
239
240# default
241# Sets a variable to the supplied default if it does not exist,
242# and adds a variable trace. The variable traces allows for delayed
243# variable and command expansion in the variable's default value.
244proc default {option val} {
245    global $option option_defaults
246    if {[info exists option_defaults($option)]} {
247        ui_debug "Re-registering default for $option"
248        # remove the old trace
249        trace vdelete $option rwu default_check
250    } else {
251        # If option is already set and we did not set it
252        # do not reset the value
253        if {[info exists $option]} {
254            return
255        }
256    }
257    set option_defaults($option) $val
258    set $option $val
259    trace variable $option rwu default_check
260}
261
262# default_check
263# trace handler to provide delayed variable & command expansion
264# for default variable values
265proc default_check {optionName index op} {
266    global option_defaults $optionName
267    switch $op {
268        w {
269            unset option_defaults($optionName)
270            trace vdelete $optionName rwu default_check
271            return
272        }
273        r {
274            upvar $optionName option
275            uplevel #0 set $optionName $option_defaults($optionName)
276            return
277        }
278        u {
279            unset option_defaults($optionName)
280            trace vdelete $optionName rwu default_check
281            return
282        }
283    }
284}
285
286# variant <provides> [<provides> ...] [requires <requires> [<requires>]]
287# Portfile level procedure to provide support for declaring variants
288proc variant {args} {
289    global all_variants PortInfo
290    upvar $args upargs
291   
292    set len [llength $args]
293    set code [lindex $args end]
294    set args [lrange $args 0 [expr $len - 2]]
295   
296    set ditem [variant_new "temp-variant"]
297   
298    # mode indicates what the arg is interpreted as.
299    # possible mode keywords are: requires, conflicts, provides
300    # The default mode is provides.  Arguments are added to the
301    # most recently specified mode (left to right).
302    set mode "provides"
303    foreach arg $args {
304        switch -exact $arg {
305            provides { set mode "provides" }
306            requires { set mode "requires" }
307            conflicts { set mode "conflicts" }
308            default { ditem_append $ditem $mode $arg }         
309        }
310    }
311    ditem_key $ditem name "[join [ditem_key $ditem provides] -]"
312   
313    # make a user procedure named variant-blah-blah
314    # we will call this procedure during variant-run
315    makeuserproc "variant-[ditem_key $ditem name]" \{$code\}
316    lappend all_variants $ditem
317   
318    # Export provided variant to PortInfo
319    lappend PortInfo(variants) [ditem_key $ditem provides]
320}
321
322# variant_isset name
323# Returns 1 if variant name selected, otherwise 0
324proc variant_isset {name} {
325    global variations
326   
327    if {[info exists variations($name)] && $variations($name) == "+"} {
328        return 1
329    }
330    return 0
331}
332
333# variant_set name
334# Sets variant to run for current portfile
335proc variant_set {name} {
336    global variations
337   
338    set variations($name) +
339}
340
341# variant_unset name
342# Clear variant for current portfile
343proc variant_unset {name} {
344    global variations
345   
346    set variations($name) -
347}
348
349# platform <os> [<release>] [<arch>]
350# Portfile level procedure to provide support for declaring platform-specifics
351# Basically, just wrap 'variant', so that Portfiles' platform declarations can
352# be more readable, and support arch and version specifics
353proc platform {args} {
354    global all_variants PortInfo os.platform os.arch os.version
355    upvar $args upargs
356   
357    set len [llength $args]
358    set code [lindex $args end]
359    set os [lindex $args 0]
360    set args [lrange $args 1 [expr $len - 2]]
361   
362    set ditem [variant_new "temp-variant"]
363   
364    foreach arg $args {
365        if {[regexp {(^[0-9]$)} $arg match result]} {
366            set release $result
367        } elseif {[regexp {([a-zA-Z0-9]*)} $arg match result]} {
368            set arch $result
369        }
370    }
371   
372    # Add the variant for this platform
373    set platform $os
374    if {[info exists release]} { set platform ${platform}_${release} }
375    if {[info exists arch]} { set platform ${platform}_${arch} }
376   
377    variant $platform $code
378   
379    # Set the variant if this platform matches the platform we're on
380    set matches 1
381    if {[info exists os.platform] && ${os.platform} == $os} { 
382        set sel_platform $os
383        if {[info exists os.version] && [info exists release]} {
384            regexp {([0-9]*)[0-9\.]?} ${os.version} match major
385            if {$major == $release } { 
386                set sel_platform ${sel_platform}_${release} 
387            } else {
388                    set matches 0
389            }
390        }
391        if {$matches == 1 && [info exists arch] && [info exists os.arch]} {
392                if {${os.arch} == $arch} {
393                        set sel_platform ${sel_platform}_${arch}
394                } else {
395                        set matches 0
396                }
397    }
398    if {$matches == 1} {
399        variant_set $sel_platform
400    }
401    }
402}
403
404########### Misc Utility Functions ###########
405
406# tbool (testbool)
407# If the variable exists in the calling procedure's namespace
408# and is set to "yes", return 1. Otherwise, return 0
409proc tbool {key} {
410    upvar $key $key
411    if {[info exists $key]} {
412        if {[string equal -nocase [set $key] "yes"]} {
413            return 1
414        }
415    }
416    return 0
417}
418
419# ldelete
420# Deletes a value from the supplied list
421proc ldelete {list value} {
422    set ix [lsearch -exact $list $value]
423    if {$ix >= 0} {
424        return [lreplace $list $ix $ix]
425    }
426    return $list
427}
428
429# reinplace
430# Provides "sed in place" functionality
431proc reinplace {pattern args}  {
432    if {$args == ""} {
433        ui_error "reinplace: no value given for parameter \"file\""
434        return -code error "no value given for parameter \"file\" to \"reinplace\"" 
435    }
436   
437    foreach file $args {
438        if {[catch {set tmpfile [mkstemp "/tmp/[file tail $file].sed.XXXXXXXX"]} error]} {
439                global errorInfo
440                ui_debug "$errorInfo"
441            ui_error "reinplace: $error"
442            return -code error "reinplace failed"
443        } else {
444            # Extract the Tcl Channel number
445            set tmpfd [lindex $tmpfile 0]
446            # Set tmpfile to only the file name
447            set tmpfile [lindex $tmpfile 1]
448        }
449       
450        if {[catch {exec sed $pattern < $file >@ $tmpfd} error]} {
451                global errorInfo
452                ui_debug "$errorInfo"
453            ui_error "reinplace: $error"
454            file delete "$tmpfile"
455            close $tmpfd
456            return -code error "reinplace sed(1) failed"
457        }
458       
459        close $tmpfd
460       
461        set attributes [file attributes $file]
462        # We need to overwrite this file
463        if {[catch {file attributes $file -permissions u+w} error]} {
464                global errorInfo
465                ui_debug "$errorInfo"
466            ui_error "reinplace: $error"
467            file delete "$tmpfile"
468            return -code error "reinplace permissions failed"
469        }
470       
471        if {[catch {exec cp $tmpfile $file} error]} {
472                global errorInfo
473                ui_debug "$errorInfo"
474            ui_error "reinplace: $error"
475            file delete "$tmpfile"
476            return -code error "reinplace copy failed"
477        }
478       
479        for {set i 0} {$i < [llength attributes]} {incr i} {
480            set opt [lindex $attributes $i]
481            incr i
482            set arg [lindex $attributes $i]
483            file attributes $file $opt $arg
484        }
485       
486        file delete "$tmpfile"
487    }
488    return
489}
490
491# filefindbypath
492# Provides searching of the standard path for included files
493proc filefindbypath {fname} {
494    global distpath filesdir workdir worksrcdir portpath
495   
496    if {[file readable $portpath/$fname]} {
497        return $portpath/$fname
498    } elseif {[file readable $portpath/$filesdir/$fname]} {
499        return $portpath/$filesdir/$fname
500    } elseif {[file readable $distpath/$fname]} {
501        return $distpath/$fname
502    }
503    return ""
504}
505
506# include
507# Source a file, looking for it along a standard search path.
508proc include {fname} {
509    set tgt [filefindbypath $fname]
510    if {[string length $tgt]} {
511        uplevel "source $tgt"
512    } else {
513        return -code error "Unable to find include file $fname"
514    }
515}
516
517# makeuserproc
518# This procedure re-writes the user-defined custom target to include
519# all the globals in its scope.  This is undeniably ugly, but I haven't
520# thought of any other way to do this.
521proc makeuserproc {name body} {
522    regsub -- "^\{(.*?)" $body "\{ \n foreach g \[info globals\] \{ \n global \$g \n \} \n \\1" body
523    eval "proc $name {} $body"
524}
525
526########### Internal Dependancy Manipulation Procedures ###########
527
528proc target_run {ditem} {
529    global target_state_fd portpath portname portversion portrevision portvariants ports_force variations workpath ports_trace PortInfo
530    set result 0
531    set skipped 0
532    set procedure [ditem_key $ditem procedure]
533    if {$procedure != ""} {
534        set name [ditem_key $ditem name]
535       
536        if {[ditem_contains $ditem init]} {
537            set result [catch {[ditem_key $ditem init] $name} errstr]
538        }
539       
540        if { ![info exists portvariants] } {
541                set portvariants ""
542                set vlist [lsort -ascii [array names variations]]
543
544                # Put together variants in the form +foo+bar for the registry
545                foreach v $vlist {
546                        if { ![string equal $v [option os.platform]] && ![string equal $v [option os.arch]] } {
547                                set portvariants "${portvariants}+${v}"
548                        }
549                }
550        }
551
552        if {$result == 0} {
553                # Skip the step if required and explain why through ui_debug.
554                # 1st case: the step was already done (as mentioned in the state file)
555                if {[check_statefile target $name $target_state_fd]} {
556                    ui_debug "Skipping completed $name ($portname)"
557                    set skipped 1
558                # 2nd case: the step is not to always be performed
559                # and this exact port/version/revision/variants is already installed
560                # and user didn't mention -f
561                # and portfile didn't change since installation.
562                } elseif {[ditem_key $ditem runtype] != "always"
563                        && [registry_exists $portname $portversion $portrevision $portvariants]
564                        && !([info exists ports_force] && $ports_force == "yes")} {
565                                               
566                        # Did the Portfile change since installation?
567                        set regref [registry_open $portname $portversion $portrevision $portvariants]
568                       
569                        set installdate [registry_prop_retr $regref date]
570                        if { $installdate != 0
571                                && $installdate < [file mtime ${portpath}/Portfile]} {
572                                ui_debug "Portfile changed since installation"
573                        } else {
574                                # Say we're skipping.
575                                set skipped 1
576                               
577                                ui_debug "Skipping $name ($portname) since this port is already installed"
578                        }
579                       
580                        # Something to close the registry entry may be called here, if it existed.
581                # 3rd case: the same port/version/revision/Variants is already active
582                # and user didn't mention -f
583                } elseif {$name == "com.apple.activate"
584                        && [registry_exists $portname $portversion $portrevision $portvariants]
585                        && !([info exists ports_force] && $ports_force == "yes")} {
586                       
587                        # Is port active?
588                        set regref [registry_open $portname $portversion $portrevision $portvariants]
589                       
590                        if { [registry_prop_retr $regref active] != 0 } {
591                                # Say we're skipping.
592                                set skipped 1
593                               
594                                ui_debug "Skipping $name ($portname) since this port is already active"
595                        }
596                       
597                }
598                       
599                # otherwise execute the task.
600                if {$skipped == 0} {
601                        set target [ditem_key $ditem provides]
602                        if {([info exists ports_trace]
603                                && $ports_trace == "yes"
604                                && $target != "clean")} {
605                                trace_start $workpath
606                        }
607
608                        # Execute pre-run procedure
609                        if {[ditem_contains $ditem prerun]} {
610                        set result [catch {[ditem_key $ditem prerun] $name} errstr]
611                        }
612                       
613                        if {$result == 0} {
614                        foreach pre [ditem_key $ditem pre] {
615                                ui_debug "Executing $pre"
616                                set result [catch {$pre $name} errstr]
617                                if {$result != 0} { break }
618                        }
619                        }
620                       
621                        if {$result == 0} {
622                        ui_debug "Executing $name ($portname)"
623                        set result [catch {$procedure $name} errstr]
624                        }
625                       
626                        if {$result == 0} {
627                        foreach post [ditem_key $ditem post] {
628                                ui_debug "Executing $post"
629                                set result [catch {$post $name} errstr]
630                                if {$result != 0} { break }
631                        }
632                        }
633                        # Execute post-run procedure
634                        if {[ditem_contains $ditem postrun] && $result == 0} {
635                        set postrun [ditem_key $ditem postrun]
636                        ui_debug "Executing $postrun"
637                        set result [catch {$postrun $name} errstr]
638                        }
639
640                        # Check dependencies & file creations outside workpath.
641                        if {([info exists ports_trace]
642                                && $ports_trace == "yes"
643                                && $target != "clean")} {
644                                set depends {}
645                                set deptypes {}
646                               
647                                # Determine deptypes to look for based on target
648                                switch $target {
649                                        configure       { set deptypes "depends_lib" }
650                                       
651                                        build           { set deptypes "depends_lib depends_build" }
652                                       
653                                        destroot        -
654                                        install         -
655                                        archive         -
656                                        pkg                     -
657                                        mpkg            -
658                                        rpmpackage      -
659                                        dpkg            -
660                                        ""                      { set deptypes "depends_lib depends_build depends_run" }
661                                }
662                               
663                                # Gather the dependencies for deptypes
664                                foreach deptype $deptypes {
665                                        # Add to the list of dependencies if the option exists and isn't empty.
666                                        if {[info exists PortInfo($deptype)] && $PortInfo($deptype) != ""} {
667                                                set depends [concat $depends $PortInfo($deptype)]
668                                        }
669                                }
670
671                                # Dependencies are in the form verb:[param:]port
672                                set depsPorts {}
673                                foreach depspec $depends {
674                                        # grab the portname portion of the depspec
675                                        set dep_portname [lindex [split $depspec :] end]
676                                        lappend depsPorts $dep_portname
677                                }
678                                trace_check_deps $depsPorts
679                               
680                                # Check files that were created.
681                                if {$target != "activate"
682                                        && $target != "archive"
683                                        && $target != "fetch"
684                                        && $target != "install"} {
685                                        trace_check_create
686                                }
687
688                                # End of trace.
689                                trace_stop
690                        }
691                }
692        }
693        if {$result == 0} {
694                # Only write to state file if:
695                # - we indeed performed this step.
696                # - this step is not to always be performed
697                # - this step must be written to file
698                if {$skipped == 0
699            && [ditem_key $ditem runtype] != "always"
700            && [ditem_key $ditem state] != "no"} {
701                write_statefile target $name $target_state_fd
702            }
703        } else {
704            ui_error "Target $name returned: $errstr"
705            set result 1
706        }
707       
708    } else {
709        ui_info "Warning: $name does not have a registered procedure"
710        set result 1
711    }
712   
713    return $result
714}
715
716proc eval_targets {target} {
717    global targets target_state_fd portname
718    set dlist $targets
719   
720    # Select the subset of targets under $target
721    if {$target != ""} {
722        set matches [dlist_search $dlist provides $target]
723       
724        if {[llength $matches] > 0} {
725            set dlist [dlist_append_dependents $dlist [lindex $matches 0] [list]]
726            # Special-case 'all'
727        } elseif {$target != "all"} {
728            ui_error "unknown target: $target"
729            return 1
730        }
731    }
732   
733    # Restore the state from a previous run.
734    set target_state_fd [open_statefile]
735   
736    set dlist [dlist_eval $dlist "" target_run]
737   
738    if {[llength $dlist] > 0} {
739        # somebody broke!
740        set errstring "Warning: the following items did not execute (for $portname):"
741        foreach ditem $dlist {
742            append errstring " [ditem_key $ditem name]"
743        }
744        ui_info $errstring
745        set result 1
746    } else {
747        set result 0
748    }
749   
750    close $target_state_fd
751    return $result
752}
753
754# open_statefile
755# open file to store name of completed targets
756proc open_statefile {args} {
757    global workpath worksymlink portname portpath ports_ignore_older
758   
759    if {![file isdirectory $workpath]} {
760        file mkdir $workpath
761    }
762    # flock Portfile
763    set statefile [file join $workpath .darwinports.${portname}.state]
764    if {[file exists $statefile]} {
765        if {![file writable $statefile]} {
766            return -code error "$statefile is not writable - check permission on port directory"
767        }
768        if {!([info exists ports_ignore_older] && $ports_ignore_older == "yes") && [file mtime $statefile] < [file mtime ${portpath}/Portfile]} {
769            ui_msg "Portfile changed since last build; discarding previous state."
770            #file delete $statefile
771            exec rm -rf [file join $workpath]
772            exec mkdir [file join $workpath]
773        }
774    }
775
776    # Create a symlink to the workpath for port authors
777    if {![file isdirectory $worksymlink]} {
778            exec ln -sf $workpath $worksymlink
779    }
780   
781    set fd [open $statefile a+]
782    if {[catch {flock $fd -exclusive -noblock} result]} {
783        if {"$result" == "EAGAIN"} {
784            ui_msg "Waiting for lock on $statefile"
785        } elseif {"$result" == "EOPNOTSUPP"} {
786            # Locking not supported, just return
787            return $fd
788        } else {
789            return -code error "$result obtaining lock on $statefile"
790        }
791    }
792    flock $fd -exclusive
793    return $fd
794}
795
796# check_statefile
797# Check completed/selected state of target/variant $name
798proc check_statefile {class name fd} {
799    global portpath workdir
800   
801    seek $fd 0
802    while {[gets $fd line] >= 0} {
803        if {$line == "$class: $name"} {
804            return 1
805        }
806    }
807    return 0
808}
809
810# write_statefile
811# Set target $name completed in the state file
812proc write_statefile {class name fd} {
813    if {[check_statefile $class $name $fd]} {
814        return 0
815    }
816    seek $fd 0 end
817    puts $fd "$class: $name"
818    flush $fd
819}
820
821# check_statefile_variants
822# Check that recorded selection of variants match the current selection
823proc check_statefile_variants {variations fd} {
824    upvar $variations upvariations
825   
826    seek $fd 0
827    while {[gets $fd line] >= 0} {
828        if {[regexp "variant: (.*)" $line match name]} {
829            set oldvariations([string range $name 1 end]) [string range $name 0 0]
830        }
831    }
832   
833    set mismatch 0
834    if {[array size oldvariations] > 0} {
835        if {[array size oldvariations] != [array size upvariations]} {
836            set mismatch 1
837        } else {
838            foreach key [array names upvariations *] {
839                if {![info exists oldvariations($key)] || $upvariations($key) != $oldvariations($key)} {
840                    set mismatch 1
841                    break
842                }
843            }
844        }
845    }
846   
847    return $mismatch
848}
849
850########### Port Variants ###########
851
852# Each variant which provides a subset of the requested variations
853# will be chosen.  Returns a list of the selected variants.
854proc choose_variants {dlist variations} {
855    upvar $variations upvariations
856   
857    set selected [list]
858   
859    foreach ditem $dlist {
860        # Enumerate through the provides, tallying the pros and cons.
861        set pros 0
862        set cons 0
863        set ignored 0
864        foreach flavor [ditem_key $ditem provides] {
865            if {[info exists upvariations($flavor)]} {
866                if {$upvariations($flavor) == "+"} {
867                    incr pros
868                } elseif {$upvariations($flavor) == "-"} {
869                    incr cons
870                }
871            } else {
872                incr ignored
873            }
874        }
875       
876        if {$cons > 0} { continue }
877       
878        if {$pros > 0 && $ignored == 0} {
879            lappend selected $ditem
880        }
881    }
882    return $selected
883}
884
885proc variant_run {ditem} {
886    set name [ditem_key $ditem name]
887    ui_debug "Executing variant $name provides [ditem_key $ditem provides]"
888   
889    # test for conflicting variants
890    foreach v [ditem_key $ditem conflicts] {
891        if {[variant_isset $v]} {
892            ui_error "Variant $name conflicts with $v"
893            return 1
894        }
895    }
896   
897    # execute proc with same name as variant.
898    if {[catch "variant-${name}" result]} {
899        global errorInfo
900        ui_debug "$errorInfo"
901        ui_error "Error executing $name: $result"
902        return 1
903    }
904    return 0
905}
906
907proc eval_variants {variations target} {
908    global all_variants ports_force PortInfo
909    set dlist $all_variants
910    set result 0
911    upvar $variations upvariations
912    set chosen [choose_variants $dlist upvariations]
913        set portname $PortInfo(name)
914
915        # Check to make sure the requested variations are available with this
916        # port, if one is not, warn the user and remove the variant from the
917        # array.
918        foreach key [array names upvariations *] {
919                if {![info exists PortInfo(variants)] || 
920                        [lsearch $PortInfo(variants) $key] == -1} {
921                        ui_debug "Requested variant $key is not provided by port $portname."
922                        array unset upvariations $key
923                }
924        }
925
926    # now that we've selected variants, change all provides [a b c] to [a-b-c]
927    # this will eliminate ambiguity between item a, b, and a-b while fulfilling requirments.
928    #foreach obj $dlist {
929    #    $obj set provides [list [join [$obj get provides] -]]
930    #}
931   
932    set newlist [list]
933    foreach variant $chosen {
934                set newlist [dlist_append_dependents $dlist $variant $newlist]
935    }
936   
937    set dlist [dlist_eval $newlist "" variant_run]
938    if {[llength $dlist] > 0} {
939                return 1
940    }
941   
942    # Make sure the variations match those stored in the statefile.
943    # If they don't match, print an error indicating a 'port clean'
944    # should be performed. 
945    # - Skip this test if the statefile is empty.
946    # - Skip this test if performing a clean.
947    # - Skip this test if ports_force was specified.
948   
949    if {$target != "clean" && 
950        !([info exists ports_force] && $ports_force == "yes")} {
951        set state_fd [open_statefile]
952       
953        if {[check_statefile_variants upvariations $state_fd]} {
954            ui_error "Requested variants do not match original selection.\nPlease perform 'port clean $portname' or specify the force option."
955            set result 1
956        } else {
957            # Write variations out to the statefile
958            foreach key [array names upvariations *] {
959                write_statefile variant $upvariations($key)$key $state_fd
960            }
961        }
962       
963        close $state_fd
964    }
965   
966    return $result
967}
968
969# Target class definition.
970
971# constructor for target object
972proc target_new {name procedure} {
973    global targets
974    set ditem [ditem_create]
975   
976    ditem_key $ditem name $name
977    ditem_key $ditem procedure $procedure
978   
979    lappend targets $ditem
980   
981    return $ditem
982}
983
984proc target_provides {ditem args} {
985    global targets
986    # Register the pre-/post- hooks for use in Portfile.
987    # Portfile syntax: pre-fetch { puts "hello world" }
988    # User-code exceptions are caught and returned as a result of the target.
989    # Thus if the user code breaks, dependent targets will not execute.
990    foreach target $args {
991        set origproc [ditem_key $ditem procedure]
992        set ident [ditem_key $ditem name]
993        if {[info commands $target] != ""} {
994            ui_debug "$ident registered provides \'$target\', a pre-existing procedure. Target override will not be provided"
995        } else {
996            eval "proc $target {args} \{ \n\
997                        variable proc_index \n\
998                        set proc_index \[llength \[ditem_key $ditem proc\]\] \n\
999                        ditem_key $ditem procedure proc-${ident}-${target}-\${proc_index}
1000                        eval \"proc proc-${ident}-${target}-\${proc_index} \{name\} \{ \n\
1001                                if \{\\\[catch userproc-${ident}-${target}-\${proc_index} result\\\]\} \{ \n\
1002                                        return -code error \\\$result \n\
1003                                \} else \{ \n\
1004                                        return 0 \n\
1005                                \} \n\
1006                        \}\" \n\
1007                        eval \"proc do-$target \{\} \{ $origproc $target\}\" \n\
1008                        makeuserproc userproc-${ident}-${target}-\${proc_index} \$args \n\
1009                \}"
1010        }
1011        eval "proc pre-$target {args} \{ \n\
1012                        variable proc_index \n\
1013                        set proc_index \[llength \[ditem_key $ditem pre\]\] \n\
1014                        ditem_append $ditem pre proc-pre-${ident}-${target}-\${proc_index}
1015                        eval \"proc proc-pre-${ident}-${target}-\${proc_index} \{name\} \{ \n\
1016                                if \{\\\[catch userproc-pre-${ident}-${target}-\${proc_index} result\\\]\} \{ \n\
1017                                        return -code error \\\$result \n\
1018                                \} else \{ \n\
1019                                        return 0 \n\
1020                                \} \n\
1021                        \}\" \n\
1022                        makeuserproc userproc-pre-${ident}-${target}-\${proc_index} \$args \n\
1023                \}"
1024        eval "proc post-$target {args} \{ \n\
1025                        variable proc_index \n\
1026                        set proc_index \[llength \[ditem_key $ditem post\]\] \n\
1027                        ditem_append $ditem post proc-post-${ident}-${target}-\${proc_index}
1028                        eval \"proc proc-post-${ident}-${target}-\${proc_index} \{name\} \{ \n\
1029                                if \{\\\[catch userproc-post-${ident}-${target}-\${proc_index} result\\\]\} \{ \n\
1030                                        return -code error \\\$result \n\
1031                                \} else \{ \n\
1032                                        return 0 \n\
1033                                \} \n\
1034                        \}\" \n\
1035                        makeuserproc userproc-post-${ident}-${target}-\${proc_index} \$args \n\
1036                \}"
1037    }
1038    eval "ditem_append $ditem provides $args"
1039}
1040
1041proc target_requires {ditem args} {
1042    eval "ditem_append $ditem requires $args"
1043}
1044
1045proc target_uses {ditem args} {
1046    eval "ditem_append $ditem uses $args"
1047}
1048
1049proc target_deplist {ditem args} {
1050    eval "ditem_append $ditem deplist $args"
1051}
1052
1053proc target_prerun {ditem args} {
1054    eval "ditem_append $ditem prerun $args"
1055}
1056
1057proc target_postrun {ditem args} {
1058    eval "ditem_append $ditem postrun $args"
1059}
1060
1061proc target_runtype {ditem args} {
1062    eval "ditem_append $ditem runtype $args"
1063}
1064
1065proc target_state {ditem args} {
1066    eval "ditem_append $ditem state $args"
1067}
1068
1069proc target_init {ditem args} {
1070    eval "ditem_append $ditem init $args"
1071}
1072
1073##### variant class #####
1074
1075# constructor for variant objects
1076proc variant_new {name} {
1077    set ditem [ditem_create]
1078    ditem_key $ditem name $name
1079    return $ditem
1080}
1081
1082proc handle_default_variants {option action args} {
1083    global variations
1084    switch -regex $action {
1085        set|append {
1086            foreach v $args {
1087                if {[regexp {([-+])([-A-Za-z0-9_]+)} $v whole val variant]} {
1088                    if {![info exists variations($variant)]} {
1089                        set variations($variant) $val
1090                    }
1091                }
1092            }
1093        }
1094        delete {
1095            # xxx
1096        }
1097    }
1098}
1099
1100
1101# builds the specified port (looked up in the index) to the specified target
1102# doesn't yet support options or variants...
1103# newworkpath defines the port's workpath - useful for when one port relies
1104# on the source, etc, of another
1105proc portexec_int {portname target {newworkpath ""}} {
1106    ui_debug "Executing $target ($portname)"
1107    set variations [list]
1108    if {$newworkpath == ""} {
1109        array set options [list]
1110    } else {
1111        set options(workpath) ${newworkpath}
1112    }
1113    # Escape regex special characters
1114    regsub -all "(\\(){1}|(\\)){1}|(\\{1}){1}|(\\+){1}|(\\{1}){1}|(\\{){1}|(\\}){1}|(\\^){1}|(\\$){1}|(\\.){1}|(\\\\){1}" $portname "\\\\&" search_string
1115   
1116    set res [dport_search ^$search_string\$]
1117    if {[llength $res] < 2} {
1118        ui_error "Dependency $portname not found"
1119        return -1
1120    }
1121   
1122    array set portinfo [lindex $res 1]
1123    set porturl $portinfo(porturl)
1124    if {[catch {set worker [dport_open $porturl [array get options] $variations]} result]} {
1125                global errorInfo
1126                ui_debug "$errorInfo"
1127        ui_error "Opening $portname $target failed: $result"
1128        return -1
1129    }
1130    if {[catch {dport_exec $worker $target} result] || $result != 0} {
1131                global errorInfo
1132                ui_debug "$errorInfo"
1133        ui_error "Execution $portname $target failed: $result"
1134        dport_close $worker
1135        return -1
1136    }
1137    dport_close $worker
1138   
1139    return 0
1140}
1141
1142# portfile primitive that calls portexec_int with newworkpath == ${workpath}
1143proc portexec {portname target} {
1144    global workpath
1145    return [portexec_int $portname $target $workpath]
1146}
1147
1148proc adduser {name args} {
1149    global os.platform
1150    set passwd {\*}
1151    set uid [nextuid]
1152    set gid [existsgroup nogroup]
1153    set realname ${name}
1154    set home /dev/null
1155    set shell /dev/null
1156   
1157    foreach arg $args {
1158        if {[regexp {([a-z]*)=(.*)} $arg match key val]} {
1159            regsub -all " " ${val} "\\ " val
1160            set $key $val
1161        }
1162    }
1163   
1164    if {[existsuser ${name}] != 0 || [existsuser ${uid}] != 0} {
1165        return
1166    }
1167   
1168    if {${os.platform} == "darwin"} {
1169        system "niutil -create . /users/${name}"
1170        system "niutil -createprop . /users/${name} name ${name}"
1171        system "niutil -createprop . /users/${name} passwd ${passwd}"
1172        system "niutil -createprop . /users/${name} uid ${uid}"
1173        system "niutil -createprop . /users/${name} gid ${gid}"
1174        system "niutil -createprop . /users/${name} realname ${realname}"
1175        system "niutil -createprop . /users/${name} home ${home}"
1176        system "niutil -createprop . /users/${name} shell ${shell}"
1177    } else {
1178        # XXX adduser is only available for darwin, add more support here
1179        ui_warn "WARNING: adduser is not implemented on ${os.platform}."
1180        ui_warn "The requested user was not created."
1181    }
1182}
1183
1184proc addgroup {name args} {
1185    global os.platform
1186    set gid [nextgid]
1187    set passwd {\*}
1188    set users ""
1189   
1190    foreach arg $args {
1191        if {[regexp {([a-z]*)=(.*)} $arg match key val]} {
1192            regsub -all " " ${val} "\\ " val
1193            set $key $val
1194        }
1195    }
1196   
1197    if {[existsgroup ${name}] != 0 || [existsgroup ${gid}] != 0} {
1198        return
1199    }
1200   
1201    if {${os.platform} == "darwin"} {
1202        system "niutil -create . /groups/${name}"
1203        system "niutil -createprop . /groups/${name} name ${name}"
1204        system "niutil -createprop . /groups/${name} gid ${gid}"
1205        system "niutil -createprop . /groups/${name} passwd ${passwd}"
1206        system "niutil -createprop . /groups/${name} users ${users}"
1207    } else {
1208        # XXX addgroup is only available for darwin, add more support here
1209        ui_warn "WARNING: addgroup is not implemented on ${os.platform}."
1210        ui_warn "The requested group was not created."
1211    }
1212}
1213
1214# proc to calculate size of a directory
1215# moved here from portpkg.tcl
1216proc dirSize {dir} {
1217    set size    0;
1218    foreach file [readdir $dir] {
1219        if {[file type [file join $dir $file]] == "link" } {
1220            continue
1221        }
1222        if {[file isdirectory [file join $dir $file]]} {
1223            incr size [dirSize [file join $dir $file]]
1224        } else {
1225            incr size [file size [file join $dir $file]];
1226        }
1227    }
1228    return $size;
1229}
1230
1231# check for a binary in the path
1232# returns an error code if it can not be found
1233proc binaryInPath {binary} {
1234    global env
1235    foreach dir [split $env(PATH) :] { 
1236        if {[file executable [file join $dir $binary]]} {
1237            return [file join $dir $binary]
1238        }
1239    }
1240   
1241    return -code error [format [msgcat::mc "Failed to locate '%s' in path: '%s'"] $binary $env(PATH)];
1242}
1243
1244# Set the UI prefix to something standard (so it can be grepped for in output)
1245proc set_ui_prefix {} {
1246        global UI_PREFIX env
1247        if {[info exists env(UI_PREFIX)]} {
1248                set UI_PREFIX $env(UI_PREFIX)
1249        } else {
1250                set UI_PREFIX "---> "
1251        }
1252}
1253
1254# Use a specified group/version.
1255proc PortGroup {group version} {
1256        global portresourcepath
1257
1258        set groupFile ${portresourcepath}/group/${group}-${version}.tcl
1259
1260        if {[file exists $groupFile]} {
1261                uplevel "source $groupFile"
1262        } else {
1263                ui_warn "Group file could not be located."
1264        }
1265}
1266
1267# check if archive type is supported by current system
1268# returns an error code if it is not
1269proc archiveTypeIsSupported {type} {
1270    global os.platform os.version
1271        set errmsg ""
1272        switch -regex $type {
1273                cp(io|gz) {
1274                        set pax "pax"
1275                        if {[catch {set pax [binaryInPath $pax]} errmsg] == 0} {
1276                                if {[regexp {z$} $type]} {
1277                                        set gzip "gzip"
1278                                        if {[catch {set gzip [binaryInPath $gzip]} errmsg] == 0} {
1279                                                return 0
1280                                        }
1281                                } else {
1282                                        return 0
1283                                }
1284                        }
1285                }
1286                t(ar|bz|gz) {
1287                        set tar "tar"
1288                        if {[catch {set tar [binaryInPath $tar]} errmsg] == 0} {
1289                                if {[regexp {z$} $type]} {
1290                                        if {[regexp {bz$} $type]} {
1291                                                set gzip "bzip2"
1292                                        } else {
1293                                                set gzip "gzip"
1294                                        }
1295                                        if {[catch {set gzip [binaryInPath $gzip]} errmsg] == 0} {
1296                                                return 0
1297                                        }
1298                                } else {
1299                                        return 0
1300                                }
1301                        }
1302                }
1303                xar {
1304                        set xar "xar"
1305                        if {[catch {set xar [binaryInPath $xar]} errmsg] == 0} {
1306                                return 0
1307                        }
1308                }
1309                zip {
1310                        set zip "zip"
1311                        if {[catch {set zip [binaryInPath $zip]} errmsg] == 0} {
1312                                set unzip "unzip"
1313                                if {[catch {set unzip [binaryInPath $unzip]} errmsg] == 0} {
1314                                        return 0
1315                                }
1316                        }
1317                }
1318                default {
1319                        return -code error [format [msgcat::mc "Invalid port archive type '%s' specified!"] $type]
1320                }
1321        }
1322        return -code error [format [msgcat::mc "Unsupported port archive type '%s': %s"] $type $errmsg]
1323}
1324
Note: See TracBrowser for help on using the repository browser.