Ignore:
Timestamp:
Mar 1, 2003, 11:37:04 PM (16 years ago)
Author:
kevin
Message:

Merging 3 days of diffs last good backup:

  • Use new dependency list package
  • Added accessors for portfile options
  • use cpio format pax(1) archives
File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/base/src/port1.0/portutil.tcl

    r2070 r2118  
    3232package provide portutil 1.0
    3333package require Pextlib 1.0
     34package require darwinports_dlist 1.0
    3435package require msgcat
    3536
     
    4445
    4546namespace eval options {
     47}
     48
     49# option
     50# This is an accessor for Portfile options.  Targets may use
     51# this in the same style as the standard Tcl "set" procedure.
     52#       name  - the name of the option to read or write
     53#       value - an optional value to assign to the option
     54
     55proc option {name args} {
     56        # XXX: right now we just transparently use globals
     57        # eventually this will need to bridge the options between
     58        # the Portfile's interpreter and the target's interpreters.
     59        global $name
     60        if {[llength $args] > 0} {
     61                ui_debug "setting option $name to $args"
     62                set $name [lindex $args 0]
     63        }
     64        return [set $name]
     65}
     66
     67# exists
     68# This is an accessor for Portfile options.  Targets may use
     69# this procedure to test for the existence of a Portfile option.
     70#       name - the name of the option to test for existence
     71
     72proc exists {name} {
     73        # XXX: right now we just transparently use globals
     74        # eventually this will need to bridge the options between
     75        # the Portfile's interpreter and the target's interpreters.
     76        global $name
     77        return [info exists $name]
    4678}
    4779
     
    253285    set args [lrange $args 0 [expr $len - 2]]
    254286   
    255     set obj [variant_new "temp-variant"]
     287    set ditem [variant_new "temp-variant"]
    256288   
    257289    # mode indicates what the arg is interpreted as.
     
    265297                        requires { set mode "requires" }
    266298                        conflicts { set mode "conflicts" }
    267                         default { $obj append $mode $arg }             
     299                        default { ditem_append $ditem $mode $arg }             
    268300        }
    269301    }
    270     $obj set name "[join [$obj get provides] -]"
     302    ditem_key $ditem name "[join [ditem_key $ditem provides] -]"
    271303
    272304    # make a user procedure named variant-blah-blah
    273305    # we will call this procedure during variant-run
    274     makeuserproc "variant-[$obj get name]" \{$code\}
    275     lappend all_variants $obj
     306    makeuserproc "variant-[ditem_key $ditem name]" \{$code\}
     307    lappend all_variants $ditem
    276308   
    277309    # Export provided variant to PortInfo
    278     lappend PortInfo(variants) [$obj get provides]
     310    lappend PortInfo(variants) [ditem_key $ditem provides]
    279311}
    280312
     
    400432########### Internal Dependancy Manipulation Procedures ###########
    401433
    402 # returns a depspec by name
    403 proc dlist_get_by_name {dlist name} {
    404     set result ""
    405     foreach d $dlist {
    406         if {[$d get name] == $name} {
    407             set result $d
    408             break
    409         }
    410     }
    411     return $result
    412 }
    413 
    414 # returns a list of depspecs that contain the given name in the given key
    415 proc depspec_get_matches {dlist key value} {
    416     set result [list]
    417     foreach d $dlist {
    418         foreach val [$d get $key] {
    419             if {$val == $value} {
    420                 lappend result $d
    421             }
    422         }
    423     }
    424     return $result
    425 }
    426 
    427 # Count the unmet dependencies in the dlist based on the statusdict
    428 proc dlist_count_unmet {dlist statusdict names} {
    429     upvar $statusdict upstatusdict
    430     set unmet 0
    431     foreach name $names {
    432         # Service was provided, check next.
    433         if {[info exists upstatusdict($name)] && $upstatusdict($name) == 1} {
    434             continue
    435         } else {
    436             incr unmet
    437         }
    438     }
    439     return $unmet
    440 }
    441 
    442 # Returns true if any of the dependencies are pending in the dlist
    443 proc dlist_has_pending {dlist uses} {
    444     foreach name $uses {
    445         if {[llength [depspec_get_matches $dlist provides $name]] > 0} {
    446             return 1
    447         }
    448     }
    449     return 0
    450 }
    451 
    452 # Get the name of the next eligible item from the dependency list
    453 proc generic_get_next {dlist statusdict} {
    454     set nextitem ""
    455     # arbitrary large number ~ INT_MAX
    456     set minfailed 2000000000
    457     upvar $statusdict upstatusdict
    458    
    459     foreach obj $dlist {               
    460         # skip if unsatisfied hard dependencies
    461         if {[dlist_count_unmet $dlist upstatusdict [$obj get requires]]} { continue }
    462        
    463         # favor item with fewest unment soft dependencies
    464         set unmet [dlist_count_unmet $dlist upstatusdict [$obj get uses]]
    465        
    466         # delay items with unmet soft dependencies that can be filled
    467         if {$unmet > 0 && [dlist_has_pending $dlist [$obj get uses]]} { continue }
    468        
    469         if {$unmet >= $minfailed} {
    470             # not better than our last pick
    471             continue
    472         } else {
    473             # better than our last pick
    474             set minfailed $unmet
    475             set nextitem $obj
    476         }
    477     }
    478     return $nextitem
    479 }
    480 
    481 
    482 # Evaluate the list of depspecs, running each as it becomes eligible.
    483 # dlist is a collection of depspec objects to be run
    484 # get_next_proc is used to determine the best item to run
    485 proc dlist_evaluate {dlist get_next_proc} {
    486     global portname
    487    
    488     # status - keys will be node names, values will be {-1, 0, 1}.
    489     array set statusdict [list]
    490    
    491     # XXX: Do we want to evaluate this dynamically instead of statically?
    492     foreach obj $dlist {
    493         if {[$obj test] == 1} {
    494             foreach name [$obj get provides] {
    495                 set statusdict($name) 1
    496             }
    497             ldelete dlist $obj
    498         }
    499     }
    500    
    501     # loop for as long as there are nodes in the dlist.
    502     while (1) {
    503         set obj [$get_next_proc $dlist statusdict]
    504        
    505         if {$obj == ""} {
    506             break
    507         } else {
    508             catch {$obj run} result
    509             # depspec->run returns an error code, so 0 == success.
    510             # translate this to the statusdict notation where 1 == success.
    511             foreach name [$obj get provides] {
    512                 set statusdict($name) [expr $result == 0]
    513             }
    514            
    515             # Delete the item from the waiting list.
    516             ldelete dlist $obj
    517         }
    518     }
    519    
    520     if {[llength $dlist] > 0} {
    521         # somebody broke!
    522         ui_info "Warning: the following items did not execute (for $portname): "
    523         foreach obj $dlist {
    524             ui_info "[$obj get name] " -nonewline
    525         }
    526         ui_info ""
    527         return 1
    528     }
    529     return 0
    530 }
    531 
    532 proc target_run {this} {
     434proc target_run {ditem} {
    533435    global target_state_fd portname
    534436    set result 0
    535     set procedure [$this get procedure]
     437    set procedure [ditem_key $ditem procedure]
    536438    if {$procedure != ""} {
    537         set name [$this get name]
    538        
    539         if {[$this has init]} {
    540             set result [catch {[$this get init] $name} errstr]
     439        set name [ditem_key $ditem name]
     440       
     441        if {[ditem_contains $ditem init]} {
     442            set result [catch {[ditem_key $ditem init] $name} errstr]
    541443        }
    542444       
     
    546448        } elseif {$result == 0} {
    547449            # Execute pre-run procedure
    548             if {[$this has prerun]} {
    549                 set result [catch {[$this get prerun] $name} errstr]
     450            if {[ditem_contains $ditem prerun]} {
     451                set result [catch {[ditem_key $ditem prerun] $name} errstr]
    550452            }
    551453           
    552454            if {$result == 0} {
    553                 foreach pre [$this get pre] {
     455                foreach pre [ditem_key $ditem pre] {
    554456                    ui_debug "Executing $pre"
    555457                    set result [catch {$pre $name} errstr]
     
    564466           
    565467            if {$result == 0} {
    566                 foreach post [$this get post] {
     468                foreach post [ditem_key $ditem post] {
    567469                    ui_debug "Executing $post"
    568470                    set result [catch {$post $name} errstr]
     
    571473            }
    572474            # Execute post-run procedure
    573             if {[$this has postrun] && $result == 0} {
    574                 set postrun [$this get postrun]
     475            if {[ditem_contains $ditem postrun] && $result == 0} {
     476                set postrun [ditem_key $ditem postrun]
    575477                ui_debug "Executing $postrun"
    576478                set result [catch {$postrun $name} errstr]
     
    578480        }
    579481        if {$result == 0} {
    580             if {[$this get runtype] != "always"} {
     482            if {[ditem_key $ditem runtype] != "always"} {
    581483                write_statefile target $name $target_state_fd
    582484            }
     
    595497
    596498proc eval_targets {target} {
    597     global targets target_state_fd
     499    global targets target_state_fd portname
    598500    set dlist $targets
    599    
    600     # Select the subset of targets under $target
     501           
     502        # Select the subset of targets under $target
    601503    if {$target != ""} {
    602         set matches [depspec_get_matches $dlist provides $target]
     504        set matches [dlist_search $dlist provides $target]
     505
    603506        if {[llength $matches] > 0} {
    604             set dlist [dlist_append_dependents $dlist [lindex $matches 0] [list]]
    605             # Special-case 'all'
    606         } elseif {$target != "all"} {
    607             ui_info "unknown target: $target"
     507                        set dlist [dlist_append_dependents $dlist [lindex $matches 0] [list]]
     508                        # Special-case 'all'
     509                } elseif {$target != "all"} {
     510                        ui_info "unknown target: $target"
    608511            return 1
    609512        }
    610513    }
    611    
     514       
    612515    # Restore the state from a previous run.
    613516    set target_state_fd [open_statefile]
    614517   
    615     set ret [dlist_evaluate $dlist generic_get_next]
    616    
     518    set dlist [dlist_eval $dlist "" target_run]
     519
     520    if {[llength $dlist] > 0} {
     521                # somebody broke!
     522                ui_info "Warning: the following items did not execute (for $portname): "
     523                foreach ditem $dlist {
     524                        ui_info "[ditem_key $ditem name] " -nonewline
     525                }
     526                ui_info ""
     527                set result 1
     528        } else {
     529                set result 0
     530        }
     531       
    617532    close $target_state_fd
    618     return $ret
    619 }
    620 
    621 # returns the names of dependents of <name> from the <itemlist>
    622 proc dlist_append_dependents {dlist obj result} {
    623    
    624     # Append the item to the list, avoiding duplicates
    625     if {[lsearch $result $obj] == -1} {
    626         lappend result $obj
    627     }
    628    
    629     # Recursively append any hard dependencies
    630     foreach dep [$obj get requires] {
    631         foreach provider [depspec_get_matches $dlist provides $dep] {
    632             set result [dlist_append_dependents $dlist $provider $result]
    633         }
    634     }
    635     # XXX: add soft-dependencies?
    636533    return $result
    637534}
     
    759656    set selected [list]
    760657   
    761     foreach obj $dlist {
     658    foreach ditem $dlist {
    762659        # Enumerate through the provides, tallying the pros and cons.
    763660        set pros 0
    764661        set cons 0
    765662        set ignored 0
    766         foreach flavor [$obj get provides] {
     663        foreach flavor [ditem_key $ditem provides] {
    767664            if {[info exists upvariations($flavor)]} {
    768665                if {$upvariations($flavor) == "+"} {
     
    779676       
    780677        if {$pros > 0 && $ignored == 0} {
    781             lappend selected $obj
     678            lappend selected $ditem
    782679        }
    783680    }
     
    785682}
    786683
    787 proc variant_run {this} {
    788     set name [$this get name]
    789     ui_debug "Executing $name provides [$this get provides]"
     684proc variant_run {ditem} {
     685    set name [ditem_key $ditem name]
     686    ui_debug "Executing $name provides [ditem_key $ditem provides]"
    790687
    791688        # test for conflicting variants
    792         foreach v [$this get conflicts] {
     689        foreach v [ditem_key $ditem conflicts] {
    793690                if {[variant_isset $v]} {
    794691                        ui_error "Variant $name conflicts with $v"
     
    823720    }
    824721   
    825     dlist_evaluate $newlist generic_get_next
     722    dlist_eval $newlist "" variant_run
    826723       
    827724        # Make sure the variations match those stored in the statefile.
     
    852749}
    853750
    854 ##### DEPSPEC #####
    855 
    856 # Object-Oriented Depspecs
    857 #
    858 # Each depspec will have its data stored in an array
    859 # (indexed by field name) and its procedures will be
    860 # called via the dispatch procedure that is returned
    861 # from depspec_new.
    862 #
    863 # sample usage:
    864 # set obj [depspec_new]
    865 # $obj set name "hello"
    866 #
    867 
    868 # Depspec
    869 #       str name
    870 #       str provides[]
    871 #       str requires[]
    872 #       str uses[]
    873 
    874 global depspec_uniqid
    875 set depspec_uniqid 0
    876 
    877 # Depspec class definition.
    878 global depspec_vtbl
    879 set depspec_vtbl(test) depspec_test
    880 set depspec_vtbl(run) depspec_run
    881 set depspec_vtbl(get) depspec_get
    882 set depspec_vtbl(set) depspec_set
    883 set depspec_vtbl(has) depspec_has
    884 set depspec_vtbl(append) depspec_append
    885 
    886 # constructor for abstract depspec class
    887 proc depspec_new {name} {
    888     global depspec_uniqid
    889     set id [incr depspec_uniqid]
    890    
    891     # declare the array of data
    892     set data dpspc_data_${id}
    893     set disp dpspc_disp_${id}
    894    
    895     global $data
    896     set ${data}(name) $name
    897     set ${data}(_vtbl) depspec_vtbl
    898    
    899     eval "proc $disp {method args} { \n \
    900                         global $data \n \
    901                         eval return \\\[depspec_dispatch $disp $data \$method \$args\\\] \n \
    902                 }"
    903    
    904     return $disp
    905 }
    906 
    907 proc depspec_get {this prop} {
    908     set data [$this _data]
    909     global $data
    910     if {[eval info exists ${data}($prop)]} {
    911         eval return $${data}($prop)
    912     } else {
    913         return ""
    914     }
    915 }
    916 
    917 proc depspec_set {this prop args} {
    918     set data [$this _data]
    919     global $data
    920     eval "set ${data}($prop) \"$args\""
    921 }
    922 
    923 proc depspec_has {this prop} {
    924     set data [$this _data]
    925     global $data
    926     eval return \[info exists ${data}($prop)\]
    927 }
    928 
    929 proc depspec_append {this prop args} {
    930     set data [$this _data]
    931     global $data
    932     set vals [join $args " "]
    933     eval lappend ${data}($prop) $vals
    934 }
    935 
    936 # is the only proc to get direct access to the object's data
    937 # so the _data accessor has to be defined here.  all other
    938 # methods are looked up in the virtual function table,
    939 # and are called with {$this $args}.
    940 proc depspec_dispatch {this data method args} {
    941     global $data
    942     if {$method == "_data"} { return $data }
    943     eval set vtbl $${data}(_vtbl)
    944     global $vtbl
    945     if {[info exists ${vtbl}($method)]} {
    946         eval set function $${vtbl}($method)
    947         eval "return \[$function $this $args\]"
    948     } else {
    949         ui_error "unknown method: $method"
    950     }
    951     return ""
    952 }
    953 
    954 proc depspec_test {this} {
    955     return 0
    956 }
    957 
    958 proc depspec_run {this} {
    959     return 0
    960 }
    961 
    962 ##### target depspec subclass #####
    963 
    964751# Target class definition.
    965 global target_vtbl
    966 array set target_vtbl [array get depspec_vtbl]
    967 set target_vtbl(run) target_run
    968 set target_vtbl(provides) target_provides
    969 set target_vtbl(requires) target_requires
    970 set target_vtbl(uses) target_uses
    971 set target_vtbl(deplist) target_deplist
    972 set target_vtbl(prerun) target_prerun
    973 set target_vtbl(postrun) target_postrun
    974 
    975 # constructor for target depspec class
     752
     753# constructor for target object
    976754proc target_new {name procedure} {
    977755    global targets
    978     set obj [depspec_new $name]
    979    
    980     $obj set _vtbl target_vtbl
    981     $obj set procedure $procedure
    982    
    983     lappend targets $obj
    984    
    985     return $obj
    986 }
    987 
    988 proc target_provides {this args} {
     756    set ditem [ditem_create]
     757       
     758        ditem_key $ditem name $name
     759        ditem_key $ditem procedure $procedure
     760   
     761    lappend targets $ditem
     762   
     763    return $ditem
     764}
     765
     766proc target_provides {ditem args} {
    989767    global targets
    990768    # Register the pre-/post- hooks for use in Portfile.
     
    993771    # Thus if the user code breaks, dependent targets will not execute.
    994772    foreach target $args {
    995         set origproc [$this get procedure]
    996         set ident [$this get name]
     773        set origproc [ditem_key $ditem procedure]
     774        set ident [ditem_key $ditem name]
    997775        if {[info commands $target] != ""} {
    998             ui_debug "[$this get name] registered provides \'$target\', a pre-existing procedure. Target override will not be provided"
     776            ui_debug "$ident registered provides \'$target\', a pre-existing procedure. Target override will not be provided"
    999777        } else {
    1000778                eval "proc $target {args} \{ \n\
    1001                         $this set procedure proc-${ident}-${target}
     779                        ditem_key $ditem procedure proc-${ident}-${target}
    1002780                        eval \"proc proc-${ident}-${target} \{name\} \{ \n\
    1003781                                if \{\\\[catch userproc-${ident}-${target} result\\\]\} \{ \n\
     
    1012790        }
    1013791        eval "proc pre-$target {args} \{ \n\
    1014                         $this append pre proc-pre-${ident}-${target}
     792                        ditem_append $ditem pre proc-pre-${ident}-${target}
    1015793                        eval \"proc proc-pre-${ident}-${target} \{name\} \{ \n\
    1016794                                if \{\\\[catch userproc-pre-${ident}-${target} result\\\]\} \{ \n\
     
    1023801                \}"
    1024802        eval "proc post-$target {args} \{ \n\
    1025                         $this append post proc-post-${ident}-${target}
     803                        ditem_append $ditem post proc-post-${ident}-${target}
    1026804                        eval \"proc proc-post-${ident}-${target} \{name\} \{ \n\
    1027805                                if \{\\\[catch userproc-post-${ident}-${target} result\\\]\} \{ \n\
     
    1034812                \}"
    1035813    }
    1036     eval "depspec_append $this provides $args"
    1037 }
    1038 
    1039 proc target_requires {this args} {
    1040     eval "depspec_append $this requires $args"
    1041 }
    1042 
    1043 proc target_uses {this args} {
    1044     eval "depspec_append $this uses $args"
    1045 }
    1046 
    1047 proc target_deplist {this args} {
    1048     eval "depspec_append $this deplist $args"
    1049 }
    1050 
    1051 proc target_prerun {this args} {
    1052     eval "depspec_append $this prerun $args"
    1053 }
    1054 
    1055 proc target_postrun {this args} {
    1056     eval "depspec_append $this postrun $args"
    1057 }
    1058 
    1059 ##### variant depspec subclass #####
    1060 
    1061 # Variant class definition.
    1062 global variant_vtbl
    1063 array set variant_vtbl [array get depspec_vtbl]
    1064 set variant_vtbl(run) variant_run
    1065 
    1066 # constructor for target depspec class
     814    eval "ditem_append $ditem provides $args"
     815}
     816
     817proc target_requires {ditem args} {
     818    eval "ditem_append $ditem requires $args"
     819}
     820
     821proc target_uses {ditem args} {
     822    eval "ditem_append $ditem uses $args"
     823}
     824
     825proc target_deplist {ditem args} {
     826    eval "ditem_append $ditem deplist $args"
     827}
     828
     829proc target_prerun {ditem args} {
     830    eval "ditem_append $ditem prerun $args"
     831}
     832
     833proc target_postrun {ditem args} {
     834    eval "ditem_append $ditem postrun $args"
     835}
     836
     837proc target_runtype {ditem args} {
     838        eval "ditem_append $ditem runtype $args"
     839}
     840
     841proc target_init {ditem args} {
     842    eval "ditem_append $ditem init $args"
     843}
     844
     845##### variant class #####
     846
     847# constructor for variant objects
    1067848proc variant_new {name} {
    1068     set obj [depspec_new $name]
    1069    
    1070     $obj set _vtbl variant_vtbl
    1071    
    1072     return $obj
     849    set ditem [ditem_create]
     850    ditem_key $ditem name $name
     851    return $ditem
    1073852}
    1074853
     
    1091870}
    1092871
    1093 ##### portfile depspec subclass #####
    1094 global portfile_vtbl
    1095 array set portfile_vtbl [array get depspec_vtbl]
    1096 set portfile_vtbl(run) portfile_run
    1097 set portfile_vtbl(test) portfile_test
    1098 
    1099 proc portfile_new {name} {
    1100     set obj [depspec_new $name]
    1101    
    1102     $obj set _vtbl portfile_vtbl
    1103    
    1104     return $obj
    1105 }
    1106 
    1107 # portfile primitive that calls portexec_int with newworkpath == ${workpath}
    1108 proc portexec {portname target} {
    1109         global workpath
    1110         portexec_int $portname $target $workpath
    1111 }
    1112 
    1113 # build the specified portfile with default workpath
    1114 proc portfile_run {this} {
    1115     set portname [$this get name]
    1116     if {![catch {portexec_int $portname install} result]} {
    1117                 portexec_int $portname clean
    1118     }
    1119     return $result
    1120 }
    1121872
    1122873# builds the specified port (looked up in the index) to the specified target
     
    1157908}
    1158909
    1159 proc portfile_test {this} {
    1160     set receipt [registry_exists [$this get name]]
    1161     if {$receipt != ""} {
    1162         ui_debug "Found Dependency: receipt: $receipt"
    1163         return 1
    1164     } else {
    1165         return 0
    1166     }
    1167 }
    1168 
    1169910proc portfile_search_path {depregex search_path} {
    1170911    set found 0
     
    1184925}
    1185926
    1186 
    1187 
    1188 ##### lib portfile depspec subclass #####
    1189 # Search registry, then library path for regex
    1190 global libportfile_vtbl
    1191 array set libportfile_vtbl [array get portfile_vtbl]
    1192 set libportfile_vtbl(test) libportfile_test
    1193 
    1194 proc libportfile_new {name match} {
    1195     set obj [portfile_new $name]
    1196    
    1197     $obj set _vtbl libportfile_vtbl
    1198     $obj set depregex $match
    1199    
    1200     return $obj
    1201 }
    1202927
    1203928# XXX - Architecture specific
     
    1243968}
    1244969
    1245 ##### bin portfile depspec subclass #####
    1246 # Search registry, then binary path for regex
    1247 global binportfile_vtbl
    1248 array set binportfile_vtbl [array get portfile_vtbl]
    1249 set binportfile_vtbl(test) binportfile_test
    1250 
    1251 proc binportfile_new {name match} {
    1252     set obj [portfile_new $name]
    1253    
    1254     $obj set _vtbl binportfile_vtbl
    1255     $obj set depregex $match
    1256    
    1257     return $obj
    1258 }
    1259 
    1260970proc binportfile_test {this} {
    1261971    global env prefix
     
    1275985        return [portfile_search_path $depregex $search_path]
    1276986    }
    1277 }
    1278 
    1279 ##### path portfile depspec subclass #####
    1280 # Search registry, then search specified absolute or
    1281 # ${prefix} relative path for regex
    1282 global pathportfile_vtbl
    1283 array set pathportfile_vtbl [array get portfile_vtbl]
    1284 set pathportfile_vtbl(test) pathportfile_test
    1285 
    1286 proc pathportfile_new {name match} {
    1287     set obj [portfile_new $name]
    1288    
    1289     $obj set _vtbl pathportfile_vtbl
    1290     $obj set depregex $match
    1291     return $obj
    1292987}
    1293988
Note: See TracChangeset for help on using the changeset viewer.