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

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

Cleanup.
portutil.tcl shouldn't depend on darwinports.tcl (and actually didn't really
depend on it, there were just some garbage from pre-create_thread times).

  • Property svn:eol-style set to native
  • Property svn:executable set to *
File size: 37.4 KB
Line 
1# et:ts=4
2# portutil.tcl
3# $Id: portutil.tcl,v 1.190 2005/08/27 06:26:34 pguyot Exp $
4#
5# Copyright (c) 2004 Robert Shaw <rshaw@opendarwin.org>
6# Copyright (c) 2002 Apple Computer, Inc.
7# All rights reserved.
8#
9# Redistribution and use in source and binary forms, with or without
10# modification, are permitted provided that the following conditions
11# are met:
12# 1. Redistributions of source code must retain the above copyright
13#    notice, this list of conditions and the following disclaimer.
14# 2. Redistributions in binary form must reproduce the above copyright
15#    notice, this list of conditions and the following disclaimer in the
16#    documentation and/or other materials provided with the distribution.
17# 3. Neither the name of Apple Computer, Inc. nor the names of its contributors
18#    may be used to endorse or promote products derived from this software
19#    without specific prior written permission.
20#
21# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
22# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
23# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
24# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
25# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
26# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
27# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
28# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
29# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
30# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
31# POSSIBILITY OF SUCH DAMAGE.
32#
33
34package provide portutil 1.0
35package require Pextlib 1.0
36package require darwinports_dlist 1.0
37package require msgcat
38package require porttrace 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 $target $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.