Ignore:
Timestamp:
Sep 26, 2002, 2:29:16 AM (16 years ago)
Author:
kevin
Message:

Change dependency evaluation engine to use depspec objects.

File:
1 edited

Legend:

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

    r781 r796  
    3535global targets target_uniqid variants
    3636
     37set targets [list]
    3738set target_uniqid 0
     39
     40set variants [list]
    3841
    3942########### External High Level Procedures ###########
     
    209212    }
    210213    set name "variant-[join $provides -]"
    211     dlist_add_item variants $name
    212     dlist_append_key variants $name provides $provides
    213     dlist_append_key variants $name requires $requires
    214     dlist_set_key variants $name procedure $code
     214    set obj [variant_new $name]
     215    $obj append provides $provides
     216    $obj append requires $requires
     217    $obj set code $code
     218        lappend variants $obj
     219
    215220    # Export provided variant to PortInfo
    216221    lappend PortInfo(variants) $provides
     
    263268proc ldelete {list value} {
    264269    upvar $list uplist
    265     set ix [lsearch -exact $uplist $value]
     270    set ix [lsearch -exact uplist $value]
    266271    if {$ix >= 0} {
    267         set uplist [lreplace $uplist $ix $ix]
     272        set uplist [lreplace uplist $ix $ix]
    268273    }
    269274}
     
    372377proc register {name mode args} {
    373378    global targets target_uniqid
    374     dlist_add_item targets $name
    375 
    376     if {[string equal target $mode]} {
     379   
     380        set obj [dlist_get_by_name $targets $name]
     381        if {$obj == ""} {
     382                set obj [target_new $name]
     383                lappend targets $obj
     384        }
     385
     386    if {$mode == "target"} {
    377387        set procedure [lindex $args 0]
    378         if {[dlist_has_key targets $name procedure]} {
     388        if {[$obj has procedure]} {
    379389            ui_debug "Warning: target '$name' re-registered (new procedure: '$procedure')"
    380390        }
    381         dlist_set_key targets $name procedure $procedure
     391        $obj set procedure $procedure
    382392               
    383         # Set runtype {always,once} if available
    384         if {[llength $args] >= 2} {
    385             dlist_set_key targets $name runtype [lindex $args 1]
    386         }
    387     } elseif {[string equal init $mode]} {
    388         set init [lindex $args 0]
    389         if {[dlist_has_key targets $name init]} {
    390            ui_debug "Warning: target '$name' re-registered init procedure (new procedure: '$init')"
    391         }
    392         dlist_set_key targets $name init $init
    393     } elseif {[string equal prerun $mode]} {
    394         set prerun [lindex $args 0]
    395         if {[dlist_has_key targets $name prerun]} {
    396            ui_debug "Warning: target '$name' re-registered pre-run procedure (new procedure: '$prerun')"
    397         }
    398         dlist_set_key targets $name prerun $prerun
    399     } elseif {[string equal postrun $mode]} {
    400         set postrun [lindex $args 0]
    401         if {[dlist_has_key targets $name postrun]} {
    402            ui_debug "Warning: target '$name' re-registered post-run procedure (new procedure: '$postrun')"
    403         }
    404         dlist_set_key targets $name postrun $postrun
    405     } elseif {[string equal requires $mode] || [string equal uses $mode] || [string equal provides $mode]} {
    406         if {[dlist_has_item targets $name]} {
    407             dlist_append_key targets $name $mode $args
    408         } else {
    409             ui_info "Warning: target '$name' not-registered in register $mode"
    410         }
     393                # Set runtype {always,once} if available
     394                if {[llength $args] >= 2} {
     395                        $obj set runtype [lindex $args 1]
     396                }
     397    } elseif {$mode == "init"} {
     398                set init [lindex $args 0]
     399                if {[$obj has init]} {
     400                        ui_debug "Warning: target '$name' re-registered init procedure (new procedure: '$init')"
     401                }
     402                $obj set init $init
     403    } elseif {$mode == "prerun"} {
     404                set prerun [lindex $args 0]
     405                if {[$obj has prerun]} {
     406                        ui_debug "Warning: target '$name' re-registered pre-run procedure (new procedure: '$prerun')"
     407                }
     408                $obj prerun $prerun
     409    } elseif {$mode == "postrun"} {
     410                set postrun [lindex $args 0]
     411                if {[$obj has postrun]} {
     412                        ui_debug "Warning: target '$name' re-registered post-run procedure (new procedure: '$postrun')"
     413                }
     414                $obj set postrun $postrun
     415    } elseif {$mode == "requires" || $mode == "uses" || $mode == "provides"} {
     416                $obj append $mode $args
    411417       
    412         if {[string equal provides $mode]} {
     418        if {$mode == "provides"} {
    413419            # If it's a provides, register the pre-/post- hooks for use in Portfile.
    414420            # Portfile syntax: pre-fetch { puts "hello world" }
     
    416422            # Thus if the user code breaks, dependent targets will not execute.
    417423            foreach target $args {
    418                 if {[info commands $target] != ""} {
    419                     ui_error "$name attempted to register provide \'$target\' which is a pre-existing procedure. Ignoring register."
    420                     continue;
    421                 }
    422                 set ident [lindex [dlist_get_matches targets provides $args] 0]
    423                 set origproc [dlist_get_key targets $ident procedure]
     424                                if {[info commands $target] != ""} {
     425                                        ui_error "$name attempted to register provide \'$target\' which is a pre-existing procedure. Ignoring register."
     426                                        continue;
     427                                }
     428                set ident [lindex [depspec_get_matches $targets provides $args] 0]
     429                set origproc [$ident get procedure]
    424430                eval "proc $target {args} \{ \n\
    425431                                        global target_uniqid \n\
     
    465471        }
    466472       
    467     } elseif {[string equal preflight $mode]} {
     473    } elseif {$mode == "preflight"} {
    468474                # Find target which provides the specified name, and add a preflight.
    469475                # XXX: this only returns the first match, is this what we want?
    470                 set ident [lindex [dlist_get_matches targets provides $name] 0]
    471                 dlist_append_key targets $ident pre $args
     476                set obj [lindex [depspec_get_matches $targets provides $name] 0]
     477                $obj append pre $args
    472478               
    473     } elseif {[string equal postflight $mode]} {
     479    } elseif {$mode == "postflight"} {
    474480                # Find target which provides the specified name, and add a preflight.
    475481                # XXX: this only returns the first match, is this what we want?
    476                 set ident [lindex [dlist_get_matches targets provides $name] 0]
    477                 dlist_append_key targets $ident post $args
     482                set obj [lindex [depspec_get_matches $targets provides $name] 0]
     483                $obj post $args
    478484        }
    479485}
     
    488494########### Internal Dependancy Manipulation Procedures ###########
    489495
    490 # Dependency List (dlist)
    491 # The dependency list is really just one big array.  (I would have
    492 # liked to make this nested arrays, but that's not feasible in Tcl,
    493 # thus we'll use the $fieldname,$groupname syntax to mimic structures.
    494 #
    495 # Dependency lists may contain private data, via the
    496 # dlist_*_key APIs.  However, it must be recognized that the
    497 # following keys are reserved for use by the evaluation engine.
    498 # (Don't fret, you want these keys anyway, honest.)  These keys also
    499 # have predefined accessor APIs to remind you of their significance.
    500 #
    501 # Reserved keys:
    502 # name          - The unique identifier of the item.  No Commas!
    503 # provides      - The list of tokens this item provides
    504 # requires      - The list of hard-dependency tokens
    505 # uses          - The list of soft-dependency tokens
    506 # runtype       - The runtype of the item {always,once}
    507 
    508 # Sets the key/value to an item in the dependency list
    509 proc dlist_set_key {dlist name key args} {
    510     upvar $dlist uplist
    511     # might be keen to validate $name here.
    512     eval "set uplist($key,$name) $args"
    513 }
    514 
    515 # Appends the value to the list stored at the key of the item
    516 proc dlist_append_key {dlist name key args} {
    517     upvar $dlist uplist
    518     if {![dlist_has_key uplist $name $key]} { set uplist($key,$name) [list] }
    519     eval "lappend uplist($key,$name) [join $args]"
    520 }
    521 
    522 # Return true if the key exists for the item, false otherwise
    523 proc dlist_has_key {dlist name key} {
    524     upvar $dlist uplist
    525     return [info exists uplist($key,$name)]
    526 }
    527 
    528 # Retrieves the value of the key of an item in the dependency list
    529 proc dlist_get_key {dlist name key} {
    530     upvar $dlist uplist
    531     if {[info exists uplist($key,$name)]} {
    532         return $uplist($key,$name)
    533     } else {
    534         return ""
    535     }
    536 }
    537 
    538 # Adds a colorless odorless item to the dependency list
    539 proc dlist_add_item {dlist name} {
    540     upvar $dlist uplist
    541     set uplist(name,$name) $name
    542 }
    543 
    544 # Deletes all keys of the specified item
    545 proc dlist_remove_item {dlist name} {
    546     upvar $dlist uplist
    547     array unset uplist *,$name
    548 }
    549 
    550 # Tests if the item is present in the dependency list
    551 proc dlist_has_item {dlist name} {
    552     upvar $dlist uplist
    553     return [info exists uplist(name,$name)]
    554 }
    555 
    556 # Return a list of names of items that provide the given name
    557 proc dlist_get_matches {dlist key value} {
    558     upvar $dlist uplist
     496# returns a depspec by name
     497proc dlist_get_by_name {dlist name} {
     498        set result ""
     499        foreach d $dlist {
     500                if {[$d get name] == $name} {
     501                        set result $d
     502                        break
     503                }
     504        }
     505        return $result
     506}
     507
     508# returns a list of depspecs that contain the given name in the given key
     509proc depspec_get_matches {dlist key value} {
    559510    set result [list]
    560     foreach ident [array names uplist name,*] {
    561         set name $uplist($ident)
    562         foreach val [dlist_get_key uplist $name $key] {
    563             if {[string equal $val $value] &&
    564                 ![info exists ${result}($name)]} {
    565                 lappend result $name
    566             }
    567         }
     511    foreach d $dlist {
     512                foreach val [$d get $key] {
     513                        if {$val == $value} {
     514                                lappend result $d
     515                        }
     516                }
    568517    }
    569518    return $result
     
    571520
    572521# Count the unmet dependencies in the dlist based on the statusdict
    573 proc dlist_count_unmet {names statusdict} {
     522proc dlist_count_unmet {dlist statusdict names} {
    574523    upvar $statusdict upstatusdict
    575524    set unmet 0
    576525    foreach name $names {
    577         if {![info exists upstatusdict($name)] ||
    578             ![string equal $upstatusdict($name) success]} {
    579             incr unmet
    580         }
     526                # Service was provided, check next.
     527                if {[info exists upstatusdict($name)] && $upstatusdict($name) == 1} {
     528                        continue
     529                } else {
     530                        incr unmet
     531                }
    581532    }
    582533    return $unmet
     
    586537proc dlist_has_pending {dlist uses} {
    587538    foreach name $uses {
    588         if {[info exists ${dlist}(name,$name)]} {
    589             return 1
    590         }
     539                if {[llength [depspec_get_matches $dlist provides $name]] > 0} {
     540                        return 1
     541                }
    591542    }
    592543    return 0
     
    594545
    595546# Get the name of the next eligible item from the dependency list
    596 proc dlist_get_next {dlist statusdict} {
     547proc generic_get_next {dlist statusdict} {
    597548    set nextitem ""
    598549    # arbitrary large number ~ INT_MAX
    599550    set minfailed 2000000000
    600     upvar $dlist uplist
    601551    upvar $statusdict upstatusdict
    602552   
    603     foreach n [array names uplist name,*] {
    604         set name $uplist($n)
     553    foreach obj $dlist {               
     554                # skip if unsatisfied hard dependencies
     555                if {[dlist_count_unmet $dlist upstatusdict [$obj get requires]]} { continue }
     556               
     557                # favor item with fewest unment soft dependencies
     558                set unmet [dlist_count_unmet $dlist upstatusdict [$obj get uses]]
     559
     560                # delay items with unmet soft dependencies that can be filled
     561                if {$unmet > 0 && [dlist_has_pending $dlist [$obj get uses]]} { continue }
     562               
     563                if {$unmet >= $minfailed} {
     564                        # not better than our last pick
     565                        continue
     566                } else {
     567                        # better than our last pick
     568                        set minfailed $unmet
     569                        set nextitem $obj
     570                }
     571    }
     572    return $nextitem
     573}
     574
     575
     576# Evaluate the list of depspecs, running each as it becomes eligible.
     577# dlist is a collection of depspec objects to be run
     578# get_next_proc is used to determine the best item to run
     579proc dlist_evaluate {dlist get_next_proc} {
     580
     581    # status - keys will be node names, values will be {-1, 0, 1}.
     582    array set statusdict [list]
    605583       
    606         # skip if unsatisfied hard dependencies
    607         if {[dlist_count_unmet [dlist_get_key uplist $name requires] upstatusdict]} { continue }
    608        
    609         # favor item with fewest unment soft dependencies
    610         set unmet [dlist_count_unmet [dlist_get_key uplist $name uses] upstatusdict]
    611        
    612         # delay items with unmet soft dependencies that can be filled
    613         if {$unmet > 0 && [dlist_has_pending dlist [dlist_get_key uplist $name uses]]} { continue }
    614        
    615         if {$unmet >= $minfailed} {
    616             # not better than our last pick
    617             continue
    618         } else {
    619             # better than our last pick
    620             set minfailed $unmet
    621             set nextitem $name
    622         }
    623     }
    624     return $nextitem
    625 }
    626 
    627 
    628 # Evaluate the dlist, invoking action on each name in the dlist as it
    629 # becomes eligible.
    630 proc dlist_evaluate {dlist downstatusdict action} {
    631     # dlist - nodes waiting to be executed
    632     upvar $dlist uplist
    633     upvar $downstatusdict statusdict
    634    
    635     # status - keys will be node names, values will be success or failure.
    636     array set statusdict [list]
     584        # XXX: Do we want to evaluate this dynamically instead of statically?
     585        foreach obj $dlist {
     586                if {[$obj test] == 1} {
     587                        foreach name [$obj get provides] {
     588                                set statusdict($name) 1
     589                        }
     590                }
     591        }
    637592   
    638593    # loop for as long as there are nodes in the dlist.
    639594    while (1) {
    640         set name [dlist_get_next uplist statusdict]
    641         if {[string length $name] == 0} {
    642             break
    643         } else {
    644             set result [eval $action uplist $name]
    645             foreach token $uplist(provides,$name) {
    646                 array set statusdict [list $token $result]
    647             }
    648             dlist_remove_item uplist $name
    649         }
     595                set obj [$get_next_proc $dlist statusdict]
     596
     597                if {$obj == ""} {
     598                        break
     599                } else {
     600                        set result [$obj run]
     601                        # depspec->run returns an error code, so 0 == success.
     602                        # translate this to the statusdict notation where 1 == success.
     603                        foreach name [$obj get provides] {
     604                                set statusdict($name) [expr $result == 0]
     605                        }
     606                       
     607                        # Delete the item from the waiting list.
     608                        set i [lsearch $dlist $obj]
     609                        set dlist [lreplace $dlist $i $i]
     610                }
    650611    }
    651612   
    652     set names [array names uplist name,*]
    653         if { [llength $names] > 0} {
     613        if {[llength $dlist] > 0} {
    654614                # somebody broke!
    655615                ui_info "Warning: the following items did not execute: "
    656                 foreach name $names {
    657                         ui_info "$uplist($name) " -nonewline
     616                foreach obj $dlist {
     617                        ui_info "[$obj get name] " -nonewline
    658618                }
    659619                ui_info ""
     
    663623}
    664624
    665 proc exec_target {fd dlist name} {
    666 # XXX: Don't depend on entire dlist, this should really receive just one node.
    667     upvar $dlist uplist
    668 
    669     if {[dlist_has_key uplist $name procedure]} {
    670                 set procedure [dlist_get_key uplist $name procedure]
    671                 if {[dlist_has_key uplist $name init]} {
    672                         [dlist_get_key uplist $name init] $name
     625proc target_run {this} {
     626        global target_state_fd
     627        set procedure [$this get procedure]
     628    if {$procedure != ""} {
     629                set name [$this get name]
     630       
     631                if {[$this has init]} {
     632                        [$this get init] $name
    673633                }
    674634                               
    675                 if {[check_statefile $name $fd]} {
     635                if {[check_statefile $name $target_state_fd]} {
    676636                        set result 0
    677637                        ui_debug "Skipping completed $name"
    678638                } else {
    679639                        # Execute pre-run procedure
    680                         if {[dlist_has_key uplist $name prerun]} {
    681                                 [dlist_get_key uplist $name prerun] $name
     640                        if {[$this has prerun]} {
     641                                [$this get prerun] $name
    682642                        }
    683643
    684                         foreach pre [dlist_get_key uplist $name pre] {
     644                        foreach pre [$this get pre] {
    685645                                ui_debug "Executing $pre"
    686646                                if {[$pre $name] != 0} { return failure }
     
    690650                        set result [$procedure $name]
    691651
    692                         foreach post [dlist_get_key uplist $name post] {
     652                        foreach post [$this get post] {
    693653                                ui_debug "Executing $post"
    694654                                if {[$post $name] != 0} {
     
    698658                        }
    699659                        # Execute post-run procedure
    700                         if {[dlist_has_key uplist $name postrun]} {
    701                                 [dlist_get_key uplist $name postrun] $name
     660                        if {[$this has postrun]} {
     661                                set postrun [$this get postrun]
     662                                ui_debug "Executing $postrun"
     663                                $postrun $name
    702664                        }
    703665                }
    704666                if {$result == 0} {
    705                         set result success
    706                         if {[dlist_get_key uplist $name runtype] != "always"} {
    707                         write_statefile $name $fd
     667                        set result 0
     668                        if {[$this get runtype] != "always"} {
     669                                write_statefile $name $target_state_fd
    708670                        }
    709671                } else {
    710672                        ui_error "Target error: $name returned $result"
    711                         set result failure
     673                        set result 1
    712674                }
    713675               
    714676    } else {
    715677                ui_info "Warning: $name does not have a registered procedure"
    716                 set result failure
    717     }
    718        
     678                set result 1
     679    }
     680
    719681    return $result
    720682}
    721683
    722 proc eval_targets {dlist target} {
    723     upvar $dlist uplist
     684proc eval_targets {target} {
     685        global targets target_state_fd
     686        set dlist $targets
    724687
    725688    # Select the subset of targets under $target
    726     if {[string length $target] > 0} {
     689    if {$target != ""} {
    727690                # XXX munge target. install really means registry, then install
    728691                # If more than one target ever needs this, make this a generic interface
    729                 if {[string equal $target "install"]} {
     692                if {$target == "install"} {
    730693                        set target registry
    731694                }
    732         set matches [dlist_get_matches uplist provides $target]
     695        set matches [depspec_get_matches $dlist provides $target]
    733696        if {[llength $matches] > 0} {
    734             array set dependents [list]
    735             dlist_append_dependents dependents uplist [lindex $matches 0]
    736             array unset uplist
    737             array set uplist [array get dependents]
    738             # Special-case 'all'
    739         } elseif {![string equal $target all]} {
    740             ui_error "unknown target: $target"
     697                        set dlist [dlist_append_dependents $dlist [lindex $matches 0] [list]]
     698                # Special-case 'all'
     699        } elseif {$target != "all"} {
     700            ui_info "unknown target: $target"
    741701            return 1
    742702        }
    743703    }
     704       
     705    # Restore the state from a previous run.
     706    set target_state_fd [open_statefile]
    744707   
    745     array set statusdict [list]
    746    
    747     # Restore the state from a previous run.
    748     set fd [open_statefile]
    749    
    750     set ret [dlist_evaluate uplist statusdict [list exec_target $fd]]
    751 
    752     close $fd
    753     return $ret
    754 }
    755 
    756 # select dependents of <name> from the <itemlist>
    757 # adding them to <dependents>
    758 proc dlist_append_dependents {dependents dlist name} {
    759     upvar $dependents updependents
    760     upvar $dlist uplist
    761 
    762     # Append item to the list, avoiding duplicates
    763     if {![info exists updependents(name,$name)]} {
    764         set names [array names uplist *,$name]
    765         foreach n $names {
    766             set updependents($n) $uplist($n)
     708    set ret [dlist_evaluate $dlist generic_get_next]
     709
     710    close $target_state_fd
     711        return $ret
     712}
     713
     714# returns the names of dependents of <name> from the <itemlist>
     715proc dlist_append_dependents {dlist obj result} {
     716
     717        # Append the item to the list, avoiding duplicates
     718        if {[lsearch $result $obj] == -1} {
     719                lappend result $obj
     720        }
     721       
     722    # Recursively append any hard dependencies
     723        foreach dep [$obj get requires] {
     724                foreach provider [depspec_get_matches $dlist provides $dep] {
     725                        set result [dlist_append_dependents $dlist $provider $result]
    767726        }
    768727    }
    769    
    770     # Recursively append any hard dependencies
    771     if {[info exists uplist(requires,$name)]} {
    772         foreach dep $uplist(requires,$name) {
    773             foreach provide [dlist_get_matches uplist provides $dep] {
    774                 dlist_append_dependents updependents uplist $provide
    775             }
    776         }
    777     }
    778    
    779728    # XXX: add soft-dependencies?
     729        return $result
    780730}
    781731
     
    861811# Each variant which provides a subset of the requested variations
    862812# will be chosen.  Returns a list of the selected variants.
    863 proc choose_variants {variants variations} {
    864     upvar $variants upvariants
     813proc choose_variants {dlist variations} {
    865814    upvar $variations upvariations
    866815
    867816    set selected [list]
    868817   
    869     foreach n [array names upvariants name,*] {
    870                 set name $upvariants($n)
    871                
     818    foreach obj $dlist {
    872819                # Enumerate through the provides, tallying the pros and cons.
    873820                set pros 0
    874821                set cons 0
    875822                set ignored 0
    876                 foreach flavor [dlist_get_key upvariants $name provides] {
     823                foreach flavor [$obj get provides] {
    877824                        if {[info exists upvariations($flavor)]} {
    878825                                if {$upvariations($flavor) == "+"} {
     
    889836               
    890837                if {$pros > 0 && $ignored == 0} {
    891                         lappend selected $name
     838                        lappend selected $obj
    892839                }
    893840        }
     
    895842}
    896843
    897 proc exec_variant {dlist name} {
    898 # XXX: Don't depend on entire dlist, this should really receive just one node.
    899     upvar $dlist uplist
    900     ui_debug "Executing $name"
    901     makeuserproc $name-code "\{[dlist_get_key uplist $name procedure]\}"
    902     $name-code
    903     return success
    904 }
    905 
    906 proc eval_variants {dlist variations} {
    907     upvar $dlist uplist
     844proc variant_run {this} {
     845        set name [$this get name]
     846    ui_debug "Executing $name provides [$this get provides]"
     847    makeuserproc $name-code "\{[$this get code]\}"
     848    if ([catch $name-code result]) {
     849                ui_error "Error executing $name: $result"
     850                return 1
     851        }
     852    return 0
     853}
     854
     855proc eval_variants {variations} {
     856        global variants
     857        set dlist $variants
    908858        upvar $variations upvariations
    909 
    910         set chosen [choose_variants uplist upvariations]
    911 
    912     # now that we've selected variants, change all provides [a b c] to [a-b-c]
     859        set chosen [choose_variants $dlist upvariations]
     860   
     861        # now that we've selected variants, change all provides [a b c] to [a-b-c]
    913862    # this will eliminate ambiguity between item a, b, and a-b while fulfilling requirments.
    914     foreach n [array names uplist provides,*] {
    915         array set uplist [list $n [join $uplist($n) -]]
    916     }
     863    #foreach obj $dlist {
     864    #    $obj set provides [list [join [$obj get provides] -]]
     865    #}
    917866       
    918         array set dependents [list]
     867        set newlist [list]
    919868    foreach variant $chosen {
    920         dlist_append_dependents dependents uplist $variant
    921     }
    922         array unset uplist
    923         array set uplist [array get dependents]
    924    
    925     array set statusdict [list]
    926        
    927     dlist_evaluate uplist statusdict [list exec_variant]
    928 }
     869        set newlist [dlist_append_dependents $dlist $variant $newlist]
     870    }
     871
     872    dlist_evaluate $newlist generic_get_next
     873}
     874
     875##### DEPSPEC #####
     876
     877# Object-Oriented Depspecs
     878#
     879# Each depspec will have its data stored in an array
     880# (indexed by field name) and its procedures will be
     881# called via the dispatch procedure that is returned
     882# from depspec_new.
     883#
     884# sample usage:
     885# set obj [depspec_new]
     886# $obj set name "hello"
     887#
     888
     889# Depspec
     890#       str name
     891#       str provides[]
     892#       str requires[]
     893#       str uses[]
     894
     895global depspec_uniqid
     896set depspec_uniqid 0
     897
     898# Depspec class definition.
     899global depspec_vtbl
     900set depspec_vtbl(test) depspec_test
     901set depspec_vtbl(run) depspec_run
     902
     903# constructor for abstract depspec class
     904proc depspec_new {name} {
     905        global depspec_uniqid
     906        set id [incr depspec_uniqid]
     907       
     908        # declare the array of data
     909        set data dpspc_data_${id}
     910        set disp dpspc_disp_${id}
     911       
     912        global $data
     913        set ${data}(name) $name
     914        set ${data}(_vtbl) depspec_vtbl
     915       
     916        eval "proc $disp {method args} { \n \
     917                        global $data \n \
     918                        eval return \\\[depspec_dispatch $disp $data \$method \$args\\\] \n \
     919                }"
     920       
     921        return $disp
     922}
     923
     924# is the only proc to get access to the object's data
     925# so the get/set routines are defined here.  this lets
     926# the virtual members get a real "this" object.
     927proc depspec_dispatch {this data method args} {
     928        global $data
     929        switch $method {
     930                get {
     931                        set prop [lindex $args 0]
     932                        if {[eval info exists ${data}($prop)]} {
     933                                eval return $${data}($prop)
     934                        } else {
     935                                return ""
     936                        }
     937                }
     938                set {
     939                        set prop [lindex $args 0]
     940                        eval "set ${data}($prop) [lrange $args 1 end]"
     941                }
     942                has {
     943                        set prop [lindex $args 0]
     944                        return [info exists ${data}($prop)]
     945                }
     946                append {
     947                        set prop [lindex $args 0]
     948                        set vals [join [lrange $args 1 end] " "]
     949                        eval "lappend ${data}($prop) $vals"
     950                }
     951                default {
     952                        eval set vtbl $${data}(_vtbl)
     953                        global $vtbl
     954                        if {[info exists ${vtbl}($method)]} {
     955                                eval set function $${vtbl}($method)
     956                                eval "return \[$function $this $args\]"
     957                        } else {
     958                                ui_error "unknown method: $method"
     959                        }
     960                }
     961        }
     962        return ""
     963}
     964
     965proc depspec_test {this} {
     966        return 0
     967}
     968
     969proc depspec_run {this} {
     970        return 0
     971}
     972
     973##### target depspec subclass #####
     974
     975# Target class definition.
     976global target_vtbl
     977array set target_vtbl [array get depspec_vtbl]
     978set target_vtbl(run) target_run
     979
     980# constructor for target depspec class
     981proc target_new {name} {
     982        set obj [depspec_new $name]
     983       
     984        $obj set _vtbl target_vtbl
     985
     986        return $obj
     987}
     988
     989##### variant depspec subclass #####
     990
     991# Variant class definition.
     992global variant_vtbl
     993array set variant_vtbl [array get depspec_vtbl]
     994set variant_vtbl(run) variant_run
     995
     996# constructor for target depspec class
     997proc variant_new {name} {
     998        set obj [depspec_new $name]
     999       
     1000        $obj set _vtbl variant_vtbl
     1001
     1002        return $obj
     1003}
     1004
     1005
     1006
     1007##### bin portfile depspec subclass #####
Note: See TracChangeset for help on using the changeset viewer.