[Summary view] [Print] [Text view]

   1  # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
   2  use strict;
   3  package CPAN::Queue::Item;
   4  
   5  # CPAN::Queue::Item::new ;
   6  sub new {
   7      my($class,@attr) = @_;
   8      my $self = bless { @attr }, $class;
   9      return $self;
  10  }
  11  
  12  sub as_string {
  13      my($self) = @_;
  14      $self->{qmod};
  15  }
  16  
  17  # r => requires, b => build_requires, c => commandline
  18  sub reqtype {
  19      my($self) = @_;
  20      $self->{reqtype};
  21  }
  22  
  23  package CPAN::Queue;
  24  
  25  # One use of the queue is to determine if we should or shouldn't
  26  # announce the availability of a new CPAN module
  27  
  28  # Now we try to use it for dependency tracking. For that to happen
  29  # we need to draw a dependency tree and do the leaves first. This can
  30  # easily be reached by running CPAN.pm recursively, but we don't want
  31  # to waste memory and run into deep recursion. So what we can do is
  32  # this:
  33  
  34  # CPAN::Queue is the package where the queue is maintained. Dependencies
  35  # often have high priority and must be brought to the head of the queue,
  36  # possibly by jumping the queue if they are already there. My first code
  37  # attempt tried to be extremely correct. Whenever a module needed
  38  # immediate treatment, I either unshifted it to the front of the queue,
  39  # or, if it was already in the queue, I spliced and let it bypass the
  40  # others. This became a too correct model that made it impossible to put
  41  # an item more than once into the queue. Why would you need that? Well,
  42  # you need temporary duplicates as the manager of the queue is a loop
  43  # that
  44  #
  45  #  (1) looks at the first item in the queue without shifting it off
  46  #
  47  #  (2) cares for the item
  48  #
  49  #  (3) removes the item from the queue, *even if its agenda failed and
  50  #      even if the item isn't the first in the queue anymore* (that way
  51  #      protecting against never ending queues)
  52  #
  53  # So if an item has prerequisites, the installation fails now, but we
  54  # want to retry later. That's easy if we have it twice in the queue.
  55  #
  56  # I also expect insane dependency situations where an item gets more
  57  # than two lives in the queue. Simplest example is triggered by 'install
  58  # Foo Foo Foo'. People make this kind of mistakes and I don't want to
  59  # get in the way. I wanted the queue manager to be a dumb servant, not
  60  # one that knows everything.
  61  #
  62  # Who would I tell in this model that the user wants to be asked before
  63  # processing? I can't attach that information to the module object,
  64  # because not modules are installed but distributions. So I'd have to
  65  # tell the distribution object that it should ask the user before
  66  # processing. Where would the question be triggered then? Most probably
  67  # in CPAN::Distribution::rematein.
  68  
  69  use vars qw{ @All $VERSION };
  70  $VERSION = sprintf "%.6f", substr(q$Rev: 2212 $,4)/1000000 + 5.4;
  71  
  72  # CPAN::Queue::queue_item ;
  73  sub queue_item {
  74      my($class,@attr) = @_;
  75      my $item = "$class\::Item"->new(@attr);
  76      $class->qpush($item);
  77      return 1;
  78  }
  79  
  80  # CPAN::Queue::qpush ;
  81  sub qpush {
  82      my($class,$obj) = @_;
  83      push @All, $obj;
  84      CPAN->debug(sprintf("in new All[%s]",
  85                          join("",map {sprintf " %s\[%s]\n",$_->{qmod},$_->{reqtype}} @All),
  86                         )) if $CPAN::DEBUG;
  87  }
  88  
  89  # CPAN::Queue::first ;
  90  sub first {
  91      my $obj = $All[0];
  92      $obj;
  93  }
  94  
  95  # CPAN::Queue::delete_first ;
  96  sub delete_first {
  97      my($class,$what) = @_;
  98      my $i;
  99      for my $i (0..$#All) {
 100          if (  $All[$i]->{qmod} eq $what ) {
 101              splice @All, $i, 1;
 102              return;
 103          }
 104      }
 105  }
 106  
 107  # CPAN::Queue::jumpqueue ;
 108  sub jumpqueue {
 109      my $class = shift;
 110      my @what = @_;
 111      CPAN->debug(sprintf("before jumpqueue All[%s] what[%s]",
 112                          join("",
 113                               map {sprintf " %s\[%s]\n",$_->{qmod},$_->{reqtype}} @All, @what
 114                              ))) if $CPAN::DEBUG;
 115      unless (defined $what[0]{reqtype}) {
 116          # apparently it was not the Shell that sent us this enquiry,
 117          # treat it as commandline
 118          $what[0]{reqtype} = "c";
 119      }
 120      my $inherit_reqtype = $what[0]{reqtype} =~ /^(c|r)$/ ? "r" : "b";
 121    WHAT: for my $what_tuple (@what) {
 122          my($what,$reqtype) = @$what_tuple{qw(qmod reqtype)};
 123          if ($reqtype eq "r"
 124              &&
 125              $inherit_reqtype eq "b"
 126             ) {
 127              $reqtype = "b";
 128          }
 129          my $jumped = 0;
 130          for (my $i=0; $i<$#All;$i++) { #prevent deep recursion
 131              # CPAN->debug("i[$i]this[$All[$i]{qmod}]what[$what]") if $CPAN::DEBUG;
 132              if ($All[$i]{qmod} eq $what) {
 133                  $jumped++;
 134                  if ($jumped >= 50) {
 135                      die "PANIC: object[$what] 50 instances on the queue, looks like ".
 136                          "some recursiveness has hit";
 137                  } elsif ($jumped > 25) { # one's OK if e.g. just processing
 138                                      # now; more are OK if user typed
 139                                      # it several times
 140                      my $sleep = sprintf "%.1f", $jumped/10;
 141                      $CPAN::Frontend->mywarn(
 142  qq{Warning: Object [$what] queued $jumped times, sleeping $sleep secs!\n}
 143                      );
 144                      $CPAN::Frontend->mysleep($sleep);
 145                      # next WHAT;
 146                  }
 147              }
 148          }
 149          my $obj = "$class\::Item"->new(
 150                                         qmod => $what,
 151                                         reqtype => $reqtype
 152                                        );
 153          unshift @All, $obj;
 154      }
 155      CPAN->debug(sprintf("after jumpqueue All[%s]",
 156                          join("",map {sprintf " %s\[%s]\n",$_->{qmod},$_->{reqtype}} @All)
 157                         )) if $CPAN::DEBUG;
 158  }
 159  
 160  # CPAN::Queue::exists ;
 161  sub exists {
 162      my($self,$what) = @_;
 163      my @all = map { $_->{qmod} } @All;
 164      my $exists = grep { $_->{qmod} eq $what } @All;
 165      # warn "in exists what[$what] all[@all] exists[$exists]";
 166      $exists;
 167  }
 168  
 169  # CPAN::Queue::delete ;
 170  sub delete {
 171      my($self,$mod) = @_;
 172      @All = grep { $_->{qmod} ne $mod } @All;
 173      CPAN->debug(sprintf("after delete mod[%s] All[%s]",
 174                          $mod,
 175                          join("",map {sprintf " %s\[%s]\n",$_->{qmod},$_->{reqtype}} @All)
 176                         )) if $CPAN::DEBUG;
 177  }
 178  
 179  # CPAN::Queue::nullify_queue ;
 180  sub nullify_queue {
 181      @All = ();
 182  }
 183  
 184  1;
 185  
 186  __END__
 187  
 188  =head1 LICENSE
 189  
 190  This program is free software; you can redistribute it and/or
 191  modify it under the same terms as Perl itself.
 192  
 193  =cut