Gentoo::Ebuild

Ebuild.pm (text/plain), 8.07 KB, created by HAGIHARA Yoshiaki on 2003-08-01 02:34:14 UTC

package Gentoo::Ebuild;

=head1 NAME

Gentoo::Ebuild - A simple class to handle ebuilds of Gentoo Linux

=head1 SYNOPSIS

 use Gentoo::Ebuild;

 # get all installed ebuilds.
 my @ebuilds = Gentoo::Ebuild->all_installed;

 # create an object by passing its full name.
 my $ebuild = Gentoo::Ebuild->create('dev-util/dialog-0.9_beta20030308-r1');
 print $ebuild->group;      # dev-util
 print $ebuild->package;    # dialog
 print $ebuild->version;    # 0.9
 print $ebuild->suffix;     # beta20030308
 print $ebuild->revision;   # 1

 # you can sort them correctly.
 @ebuilds = (
   Gentoo::Ebuild->create('net-www/galeon-1.2.10b'),
   Gentoo::Ebuild->create('net-www/apache-1.3.27-r3'),
   Gentoo::Ebuild->create('net-www/galeon-1.2.7-r1'),
   Gentoo::Ebuild->create('net-www/galeon-1.2.10_pre4'),
   Gentoo::Ebuild->create('net-www/apache-1.3.27-r4'),
   Gentoo::Ebuild->create('net-www/galeon-1.2.9'),
   Gentoo::Ebuild->create('net-www/galeon-1.2.10'),
   Gentoo::Ebuild->create('net-www/galeon-1.2.10_alpha2'),
   Gentoo::Ebuild->create('net-www/galeon-1.2.10a'),
   Gentoo::Ebuild->create('gnome-extra/gal-0.24'),
   Gentoo::Ebuild->create('net-www/apache-1.3.27'),
   Gentoo::Ebuild->create('net-www/apache-1.3.28'),
   Gentoo::Ebuild->create('net-www/apache-2.0.47'),
 );
 foreach(sort @ebuilds){
   print $_,"\n";
 }
 # => gnome-extra/gal-0.24
 # => net-www/apache-1.3.27
 # => net-www/apache-1.3.27-r3
 # => net-www/apache-1.3.27-r4
 # => net-www/apache-1.3.28
 # => net-www/apache-2.0.47
 # => net-www/galeon-1.2.7-r1
 # => net-www/galeon-1.2.9
 # => net-www/galeon-1.2.10_alpha2
 # => net-www/galeon-1.2.10_pre4
 # => net-www/galeon-1.2.10
 # => net-www/galeon-1.2.10a
 # => net-www/galeon-1.2.10b
    
 # and you can check whether the package is installed.
 for(1..5){
   my $ebuild = Gentoo::Ebuild->new(
     group    => 'sys-kernel',
     package  => 'gentoo-sources',
     version  => '2.4.20',
     revision => $_,
   );
   print "$ebuild is ";
   print $ebuild->installed ? "installed.\n" : "not installed.\n";
 }

=head1 DESCRIPTION

B<Gentoo::Ebuild> is a simple class to handle ebuilds like sorting
packages or cheking installed status. You can also get all installed
packages as an array of Gentoo::Ebuild.

=cut

use strict;
use overload
  '""'  => \&as_string,
  'cmp' => \&compare
;
use File::Basename qw(dirname);
use File::Find;
use File::Spec::Functions qw(splitdir catfile);

use vars qw($VERSION);
$VERSION='0.20';

=head1 OBJECT METHODS

=item new

Creates object by passing group, package, version, suffix1, suffix2 and
revision. Suffix1 is a emtpy string or a string like following: "alpha",
"beta", "pre", "rc" and "p". Suffix2 is a number embellishes suffix1.

Currently, no value check codes exists.

=cut

sub new{
  my $class=shift;

  my $self=bless {
    group     => '',
    package   => '',
    version   => '',
    suffix1   => '',
    suffix2   => '',
    revision  => '',
    @_, 
  },$class;

  return $self;
}

=item group

=item package

=item version

=item suffix1

=item suffix2

=item revision

=item category

=item suffix

You can access the value of the object by accessors: group, package, version,
suffix1, suffix2, revision. You can use category method as synonym of
group. Suffix method returns a string value suffix1 plus suffix2.

You cannot set values by these accessors.

=cut

sub group    { my $self=shift; return $self->{group};                       }
sub category { my $self=shift; return $self->group;                         }
sub package  { my $self=shift; return $self->{package};                     }
sub version  { my $self=shift; return $self->{version};                     }
sub suffix1  { my $self=shift; return $self->{suffix1};                     }
sub suffix2  { my $self=shift; return $self->{suffix2};                     }
sub suffix   { my $self=shift; return $self->{suffix1} . $self->{suffix2};  }
sub revision { my $self=shift; return $self->{revision};                    }

=item long_name

Returns the long name of package - package name, version, suffix and revision
with suitable under bar and '-r' of revision.

=cut

sub long_name{
  my $self=shift;

  return sprintf
    '%s-%s%s%s%s',
    $self->{package},
    $self->{version},
    $self->{suffix1}  ? '_'  . $self->{suffix1}  : '',
    $self->{suffix2},
    $self->{revision} ? '-r' . $self->{revision} : '',
  ;
}

=item installed

Returns whether the package is installed by looking into /var/db/pkg.

=cut

sub installed{
  my $self =shift;

  return $self->{installed} if exists $self->{installed};

  $self->{installed}=-f sprintf(
    '/var/db/pkg/%s/%s/%s.ebuild',
    $self->{group},
    $self->long_name,
    $self->long_name,
  );

  return $self->{installed};
}

=item set_installed

You can set installed status by set_installed method. Remenber the installed
method returns the status you set without checking package directory.

=cut

sub set_installed{
  my $self =shift;
  my $value=shift;

  $self->{installed}=$value;

  return $self;
}

=head1 INSTANCE METHODS

=item create

Creates Gentoo::Ebuild object by passing a string of ebuild - like 
"dev-lang/perl-5.8.0-r12".

If the method fails to parse the string, it returns undef.

=cut

sub create{
  my $class=shift;

  my $ebuild=shift; 

  if($ebuild=~/
      ^
      (\w+-\w+)                         # group
      \/
      ([\w+-]+)                         # package
      -
      ([\d\.]+(?:[a-zA-Z])?)?           # version
      _?
      (?:(alpha|beta|pre|rc|p)(\d+)?)?  # suffix
      (?:-r([\d\.]+))?                  # revision
      $
    /x
  ){
    return $class->new(
      group     => defined $1 ? $1 : '',
      package   => defined $2 ? $2 : '',
      version   => defined $3 ? $3 : '',
      suffix1   => defined $4 ? $4 : '',
      suffix2   => defined $5 ? $5 : '',
      revision  => defined $6 ? $6 : '',
    );
  }
}

=item all_installed

You can get all installed packages as an array using this method.

The code of this method is borrowed from app-admin/splat-0.06.

=cut

sub all_installed{
  # borrowed from splat.

  my $class=shift;

  my @INSTALLED = ();
  find({ 'wanted' => 
    sub {
      return unless /\.ebuild$/;

      my $basedir = dirname($File::Find::name);
         $basedir =~ s/^\/var\/db\/pkg//;
      my $package = join('/',(splitdir($basedir))[1,2]);

      push @INSTALLED, $class->create($package);

      $INSTALLED[-1]->set_installed(1);

    }, 'no_chdir' => 1, },
    '/var/db/pkg',
  );

  return @INSTALLED;
}

=head1 OPERATORS

=item "$ebuild"

If you use the object as string, Gentoo::Ebuild returns a long name of the
package with its group.

=cut

sub as_string{
  my $self=shift;

  return sprintf
    '%s/%s',
    $self->{group},
    $self->long_name,
  ;
}

=item EBUILD1 cmp EBUILD2

You can compare two object of Gentoo::EBUILD2 using cmp. So, you can sort
the bunch of packges.

=cut

sub _split_version{
  my $version=shift;

  if($version=~/^([\d\.]+)([a-zA-Z])?$/){
    return
      [split(/\./,$1)],
      $2 || ''
    ;
  }
}

sub _compare_version{
  my($a,$b)=@_;

  my($digits_a,$alphabet_a)=_split_version($a->{version});
  my($digits_b,$alphabet_b)=_split_version($b->{version});

  my $compare_length=(
    scalar(@{$digits_a}),scalar(@{$digits_b})
  )[scalar(@{$digits_a})<scalar(@{$digits_b})];

  for(my $i=0;$i<$compare_length;$i++){
    my $result=($digits_a->[$i] || 0)<=>($digits_b->[$i] || 0);
    return $result if $result;
  }

  return $alphabet_a cmp $alphabet_b;
}

my %SUFFIXES=(
  alpha => 0,
  beta  => 1,
  pre   => 2,
  rc    => 3,
  ''    => 4,
  p     => 5,
);

sub _compare_suffix{
  my($a,$b)=@_;

  return
    $SUFFIXES{$a->{suffix1}} <=> $SUFFIXES{$b->{suffix1}} ||
    ($a->{suffix2} || 0)     <=> ($b->{suffix2} || 0)
  ;
}

sub compare{
  my($a,$b)=@_;

  return
    $a->{group}   cmp $b->{group}                   ||
    $a->{package} cmp $b->{package}                 ||
    _compare_version($a,$b)                         ||
    _compare_suffix($a,$b)                          ||
    ($a->{revision} || 0) <=> ($b->{revision} || 0)
  ;
}
#------------------------------------------------------------------------------#

=head1 LICENSE

GPL v2(or later) or Perl Artistic License.

=head1 AUTHOR

Yoshiaki Hagihara <[e-mail]>.

=cut

1;