lib/Packages/Page.pm

   1 package Packages::Page;
   2
   3 use Deb::Versions;
   4
   5 our $ARCHIVE_DEFAULT = '';
   6 our $SECTION_DEFAULT = 'main';
   7 our $SUBSECTION_DEFAULT = 'unknown';
   8 our $PRIORITY_DEFAULT = 'unknown';
   9 our $ESSENTIAL_DEFAULT = 'no';
  10 our $MAINTAINER_DEFAULT = 'unknown <unknown@email.invalid>';
  11
  12 sub new {
  13     my $classname = shift;
  14     my $name = shift || '';
  15     my $config = shift || {};
  16
  17     my $self = {};
  18     bless( $self, $classname );
  19
  20     $self->{package} = $name;
  21     $self->{config} = $config;
  22
  23     return $self;
  24 }
  25
  26 sub merge_data {
  27     my ($self, $data) = @_;
  28
  29     local $/ = "";
  30     open DATA, '<', \$data
  31         or return;
  32     my $merged = 0;
  33     while (<DATA>) {
  34         next if /^\s*$/;
  35         my %data = ();
  36         chomp;
  37         s/\n /\377/g;
  38         while (/^(\S+):\s*(.*)\s*$/mg) {
  39             my ($key, $value) = ($1, $2);
  40             $value =~ s/\377/\n /g;
  41             $key =~ tr [A-Z] [a-z];
  42             $data{$key} = $value;
  43         }
  44         $merged += $self->merge_package( \%data );
  45     }
  46     close DATA;
  47     return $merged;
  48 }
  49
  50 our @TAKE_NEWEST = qw( description essential priority section subsection tags );
  51 our @STORE_ALL = qw( version source installed-size size filename md5sum
  52                      origin bugs suite archive section );
  53 our @DEP_FIELDS = qw( depends pre-depends recommends suggests enhances
  54                       provides conflicts );
  55 sub merge_package {
  56     my ($self, $data) = @_;
  57
  58     ($data{package} && $data{version} && $data{architecture}) || return;
  59     $self->{package} ||= $data{package};
  60     ($self->{package} eq $data{package}) || return;
  61
  62     unless ($self->{newest}) {
  63         foreach my $key (@TAKE_NEWEST) {
  64             $self->{data}{$key} = $data->{$key};
  65         }
  66         foreach my $key (@STORE_ALL) {
  67             $self->{versions}{$data->{architecture}}{$key}
  68             = $data->{$key};
  69         }
  70         foreach my $key (@DEP_FIELDS) {
  71             $self->normalize_dependencies($key, $data);
  72         }
  73         $self->{newest} = $data->{version};
  74
  75         return 1;
  76     }
  77
  78     if (my $is_newest =
  79         (version_cmp( $data->{version}, $self->{newest} ) > 0)) {
  80         $self->{newest} = $data->{version};
  81         foreach my $key (@TAKE_NEWEST) {
  82             $self->{data}{$key} = $data->{$key};
  83         }
  84     }
  85     if (!$self->{versions}{$data->{architecture}}
  86         || $is_newest
  87         || (version_cmp( $data->{version},
  88                          $self->{versions}{$data->{architecture}} ) > 0)) {
  89         foreach my $key (@STORE_ALL) {
  90             $self->{versions}{$data->{architecture}}{$key}
  91             = $data->{$key};
  92         }
  93         foreach my $key (@DEP_FIELDS) {
  94             $self->normalize_dependencies($key, $data);
  95         }
  96     }
  97
  98 }
  99
 100 sub normalize_dependencies {
 101     my ($self, $dep_field, $data) = @_;
 102
 103     my ($deps_norm, $deps) = parse_deps( $data->{$dep_field}||'' );
 104     $self->{dep_fields}{$data->{architecture}}{$dep_field} =
 105         [ $deps_norm, $deps ];
 106 }
 107
 108 sub parse_deps {
 109     my ($dep_str) = @_;
 110
 111     my (@dep_and_norm, @dep_and);
 112     foreach my $dep_and (split( /\s*,\s*/m, $dep_str )) {
 113         next if $dep_and =~ /^\s*$/;
 114         my (@dep_or_norm, @dep_or);
 115         foreach my $dep_or (split( /\s*\|\s*/m, $dep_and )) {
 116             my ($pkg, $relation, $version, @arches) = ('','','');
 117             $pkg = $1 if $dep_or =~ s/^([a-zA-Z0-9][a-zA-Z0-9+._-]*)\s*//m;
 118             ($relation, $version) = ($1, $2)
 119                 if $dep_or =~ s/^\(\s*(=|<=|>=|<<?|>>?)\s*([^\)]+).*\)\s*//m;
 120             @arches = split(/\s+/m, $1) if $dep_or =~ s/^\[([^\]]+)\]\s*//m;
 121             push @dep_or_norm, "$pkg($relation$version)[".
 122                 join(" ",sort(@arches))."]";
 123             push @dep_or, [ $pkg, $relation, $version, \@arches ];
 124         }
 125         push @dep_and_norm, join('|',@dep_or_norm);
 126         push @dep_and, \@dep_or;
 127     }
 128     return (\@dep_and_norm, \@dep_and);
 129 }
 130
 131 sub get_arch_field {
 132     my ($self, $field) = @_;
 133
 134     my @result;
 135     foreach (sort keys %{$self->{versions}}) {
 136         push(@result, $self->{versions}{$_}{$field})
 137             if $self->{versions}{$_}{$field};
 138     }
 139
 140     return \@result;
 141 }
 142
 143 sub get_version_string {
 144     my ($self) = @_;
 145
 146     my %versions;
 147     foreach (keys %{$self->{versions}}) {
 148         my $version = $self->{versions}{$_}{version};
 149         $versions{$version} ||= [];
 150         push @{$versions{$version}}, $_;
 151     }
 152
 153     my @versions = version_sort keys %versions;
 154     if ( scalar @versions == 1 ) {
 155         @v_str = ( [ $versions[0], undef ] );
 156         $v_str = $versions[0];
 157         $v_str_arch = $versions[0];
 158     } else {
 159         my @v_str_arch;
 160         foreach ( @versions ) {
 161             push @v_str, [ $_, $versions{$_} ];
 162             push @v_str_arch, "$_ [".join(', ', @{$versions{$_}})."]";
 163         }
 164         $v_str_arch = join( ", ", @v_str_arch );
 165         $v_str = join( ", ",  @versions );
 166     }
 167
 168     return ($v_str, $v_str_arch, \@v_str);
 169 }
 170
 171 sub get_dep_field {
 172     my ($self, $dep_field) = @_;
 173
 174     my @architectures = ( keys %{$self->{versions}} );
 175
 176     my ( %dep_pkgs, %arch_deps );
 177     foreach my $a ( @architectures ) {
 178         next unless exists $self->{dep_fields}{$a}{$dep_field};
 179         my (@a_deps_norm, @a_deps) = @{$self->{dep_fields}{$a}{$type}};
 180         for ( my $i=0; $i < $#a_deps; $i++ ) { # splitted by ,
 181             $dep_pkgs{$a_deps_norm[$i]} = $a_deps[$i];
 182             $arch_deps{$a}{$a_deps_norm[$i]}++;
 183         }
 184     }
 185     @architectures = sort keys %arch_deps;
 186 #    print Dumper( \%dep_pkgs, \%arch_deps );
 187
 188     my @deps;
 189     if ( %dep_pkgs ) {
 190         my $old_pkgs = '';
 191         my $is_old_pkgs = 0;
 192         foreach my $dp ( sort keys %dep_pkgs ) {
 193             my @dp_alts = @{$dep_pkgs{$dp}};
 194             my ( @pkgs, $pkgs );
 195             foreach (@dp_alts) { push @pkgs, $_->[0]; }
 196             $pkgs = "@pkgs";
 197
 198             unless ( $is_old_pkgs = ($pkgs eq $old_pkgs) ) {
 199                 $old_pkgs = $pkgs;
 200             }
 201
 202             my ($arch_neg, $arch_str) = _compute_arch_str ( $dp, \%arch_deps,
 203                                                             \@architectures );
 204
 205             my @res_pkgs; my $pkg_ix = 0;
 206             foreach my $p_name ( @pkgs ) {
 207                 if ( $pkg_ix > 0 ) { $arch_str = ""; }
 208
 209                 my $pkg_version = "";
 210                 $pkg_version = "$dep_pkgs{$dp}[$pkg_ix][1] $dep_pkgs{$dp}[$pkg_ix][2]"
 211                     if $dep_pkgs{$dp}[$pkg_ix][1];
 212
 213
 214                 push @res_pkgs, [ $p_name, $pkg_version, $arch_neg,
 215                                   $arch_str ];
 216                 $pkg_ix++;
 217             }
 218             push @deps, [ $is_old_pkgs, @res_pkgs ];
 219         }
 220     }
 221     return @deps;
 222 }
 223
 224 sub _compute_arch_str {
 225     my ( $dp, $arch_deps, $all_archs, $is_src_dep ) = @_;
 226
 227     my ( @dependend_archs, @not_dependend_archs );
 228     my $arch_str;
 229     foreach my $a ( @$all_archs ) {
 230         if ( exists $arch_deps->{$a}{$dp} ) {
 231             push @dependend_archs, $a;
 232         } else {
 233             push @not_dependend_archs, $a;
 234         }
 235     }
 236     my $arch_neg = 0;
 237     if ( @dependend_archs == @$all_archs ) {
 238         $arch_str = "";
 239     } else {
 240         if ( @dependend_archs > (@$all_archs/2) ) {
 241             $arch_neg = 1;
 242             $arch_str = join( ", ", @not_dependend_archs);
 243         } else {
 244             $arch_str = join( ", ", @dependend_archs);
 245         }
 246     }
 247     return my @ret = ( $arch_neg, $arch_str );
 248 }
 249
 250 1;