| line | stmt | bran | cond | sub | pod | time | code | 
| 1 |  |  |  |  |  |  | package Algorithm::Dependency::Ordered; | 
| 2 |  |  |  |  |  |  | # ABSTRACT: Implements an ordered dependency hierarchy | 
| 3 |  |  |  |  |  |  |  | 
| 4 |  |  |  |  |  |  | #pod =pod | 
| 5 |  |  |  |  |  |  | #pod | 
| 6 |  |  |  |  |  |  | #pod =head1 DESCRIPTION | 
| 7 |  |  |  |  |  |  | #pod | 
| 8 |  |  |  |  |  |  | #pod Algorithm::Dependency::Ordered implements the most common variety of | 
| 9 |  |  |  |  |  |  | #pod L, the one in which the dependencies of an item must | 
| 10 |  |  |  |  |  |  | #pod be acted upon before the item itself can be acted upon. | 
| 11 |  |  |  |  |  |  | #pod | 
| 12 |  |  |  |  |  |  | #pod In use and semantics, this should be used in exactly the same way as for the | 
| 13 |  |  |  |  |  |  | #pod main parent class. Please note that the output of the C method is | 
| 14 |  |  |  |  |  |  | #pod NOT changed, as the order of the depends is not assumed to be important. | 
| 15 |  |  |  |  |  |  | #pod Only the output of the C method is modified to ensure the correct | 
| 16 |  |  |  |  |  |  | #pod order. | 
| 17 |  |  |  |  |  |  | #pod | 
| 18 |  |  |  |  |  |  | #pod For API details, see L. | 
| 19 |  |  |  |  |  |  | #pod | 
| 20 |  |  |  |  |  |  | #pod =cut | 
| 21 |  |  |  |  |  |  |  | 
| 22 | 4 |  |  | 4 |  | 72499 | use 5.005; | 
|  | 4 |  |  |  |  | 23 |  | 
| 23 | 4 |  |  | 4 |  | 21 | use strict; | 
|  | 4 |  |  |  |  | 8 |  | 
|  | 4 |  |  |  |  | 81 |  | 
| 24 | 4 |  |  | 4 |  | 504 | use Algorithm::Dependency (); | 
|  | 4 |  |  |  |  | 7 |  | 
|  | 4 |  |  |  |  | 1252 |  | 
| 25 |  |  |  |  |  |  |  | 
| 26 |  |  |  |  |  |  | our $VERSION = '1.111'; | 
| 27 |  |  |  |  |  |  | our @ISA     = 'Algorithm::Dependency'; | 
| 28 |  |  |  |  |  |  |  | 
| 29 |  |  |  |  |  |  |  | 
| 30 |  |  |  |  |  |  | sub schedule { | 
| 31 | 48 |  |  | 48 | 1 | 36718 | my $self   = shift; | 
| 32 | 48 |  |  |  |  | 103 | my $source = $self->{source}; | 
| 33 | 48 | 50 |  |  |  | 145 | my @items  = @_ or return undef; | 
| 34 | 48 | 50 |  |  |  | 105 | return undef if grep { ! $source->item($_) } @items; | 
|  | 48 |  |  |  |  | 136 |  | 
| 35 |  |  |  |  |  |  |  | 
| 36 |  |  |  |  |  |  | # The actual items to select will be the same as for the unordered | 
| 37 |  |  |  |  |  |  | # version, so we can simplify the algorithm greatly by using the | 
| 38 |  |  |  |  |  |  | # normal unordered ->schedule method to get the starting list. | 
| 39 | 48 |  |  |  |  | 148 | my $rv    = $self->SUPER::schedule( @items ); | 
| 40 | 48 | 100 |  |  |  | 145 | my @queue = $rv ? @$rv : return undef; | 
| 41 |  |  |  |  |  |  |  | 
| 42 |  |  |  |  |  |  | # Get a working copy of the selected index | 
| 43 | 47 |  |  |  |  | 77 | my %selected = %{ $self->{selected} }; | 
|  | 47 |  |  |  |  | 144 |  | 
| 44 |  |  |  |  |  |  |  | 
| 45 |  |  |  |  |  |  | # If at any time we check every item in the stack without finding | 
| 46 |  |  |  |  |  |  | # a suitable candidate for addition to the schedule, we have found | 
| 47 |  |  |  |  |  |  | # a circular reference error. We need to create a marker to track this. | 
| 48 | 47 |  |  |  |  | 94 | my $error_marker = ''; | 
| 49 |  |  |  |  |  |  |  | 
| 50 |  |  |  |  |  |  | # Begin the processing loop | 
| 51 | 47 |  |  |  |  | 75 | my @schedule = (); | 
| 52 | 47 |  |  |  |  | 114 | while ( my $id = shift @queue ) { | 
| 53 |  |  |  |  |  |  | # Have we checked every item in the stack? | 
| 54 | 135 | 50 |  |  |  | 275 | return undef if $id eq $error_marker; | 
| 55 |  |  |  |  |  |  |  | 
| 56 |  |  |  |  |  |  | # Are there any un-met dependencies | 
| 57 | 135 | 50 |  |  |  | 294 | my $Item    = $self->{source}->item($id) or return undef; | 
| 58 | 135 |  |  |  |  | 287 | my @missing = grep { ! $selected{$_} } $Item->depends; | 
|  | 151 |  |  |  |  | 372 |  | 
| 59 |  |  |  |  |  |  |  | 
| 60 |  |  |  |  |  |  | # Remove orphans if we are ignoring them | 
| 61 | 135 | 100 |  |  |  | 289 | if ( $self->{ignore_orphans} ) { | 
| 62 | 1 |  |  |  |  | 2 | @missing = grep { $self->{source}->item($_) } @missing; | 
|  | 1 |  |  |  |  | 2 |  | 
| 63 |  |  |  |  |  |  | } | 
| 64 |  |  |  |  |  |  |  | 
| 65 | 135 | 100 |  |  |  | 243 | if ( @missing ) { | 
| 66 |  |  |  |  |  |  | # Set the error marker if not already | 
| 67 | 41 | 100 |  |  |  | 80 | $error_marker = $id unless $error_marker; | 
| 68 |  |  |  |  |  |  |  | 
| 69 |  |  |  |  |  |  | # Add the id back to the end of the queue | 
| 70 | 41 |  |  |  |  | 71 | push @queue, $id; | 
| 71 | 41 |  |  |  |  | 107 | next; | 
| 72 |  |  |  |  |  |  | } | 
| 73 |  |  |  |  |  |  |  | 
| 74 |  |  |  |  |  |  | # All dependencies have been met. Add the item to the schedule and | 
| 75 |  |  |  |  |  |  | # to the selected index, and clear the error marker. | 
| 76 | 94 |  |  |  |  | 179 | push @schedule, $id; | 
| 77 | 94 |  |  |  |  | 157 | $selected{$id} = 1; | 
| 78 | 94 |  |  |  |  | 260 | $error_marker  = ''; | 
| 79 |  |  |  |  |  |  | } | 
| 80 |  |  |  |  |  |  |  | 
| 81 |  |  |  |  |  |  | # All items have been added | 
| 82 | 47 |  |  |  |  | 209 | \@schedule; | 
| 83 |  |  |  |  |  |  | } | 
| 84 |  |  |  |  |  |  |  | 
| 85 |  |  |  |  |  |  | 1; | 
| 86 |  |  |  |  |  |  |  | 
| 87 |  |  |  |  |  |  | __END__ |