<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">package Debian::Dependency;

use strict;
use warnings;

our $VERSION = '0.77';

use AptPkg::Config;
use Carp;
use Dpkg::Version ();
use List::MoreUtils qw(mesh);

=head1 NAME

Debian::Dependency - dependency relationship between Debian packages

=head1 SYNOPSIS

                                    # simple dependency
   my $d = Debian::Dependency-&gt;new( 'perl' );
                                    # also parses a single argument
   my $d = Debian::Dependency-&gt;new('perl (&gt;= 5.10)');
                                    # dependency with a version
   my $d = Debian::Dependency-&gt;new( 'perl', '5.10' );
                                    # dependency with version and relation
   my $d = Debian::Dependency-&gt;new( 'perl', '&gt;=', '5.10' );

   print $d-&gt;pkg;  # 'perl'
   print $d-&gt;ver;  # '5.10'

                                    # for people who like to type much
   my $d = Debian::Dependency-&gt;new( { pkg =&gt; 'perl', ver =&gt; '5.10' } );

   # stringification
   print "$d"      # 'perl (&gt;= 5.10)'

   # 'adding'
   $deps = $dep1 + $dep2;
   $deps = $dep1 + 'foo (&gt;= 1.23)'

=cut

use base qw(Class::Accessor);
__PACKAGE__-&gt;mk_accessors(qw( pkg ver rel alternatives ));

use Carp;

use overload '""' =&gt; \&amp;_stringify,
             '+'  =&gt; \&amp;_add,
             '&lt;=&gt;'  =&gt; \&amp;_compare;

=head2 CLASS_METHODS

=over 4

=item new()

Construct a new instance.

=item new( { pkg =&gt; 'package', rel =&gt; '&gt;=', ver =&gt; '1.9' } )

If a hash reference is passed as an argument, its contents are used to
initialize the object.

=item new( [ { pkg =&gt; 'foo' }, 'bar (&lt;= 3)' ] );

In an array reference is passed as an argument, its elements are used for
constructing a dependency with alternatives.

=item new('foo (= 42)')

=item new('foo (= 42) | bar')

If a single argument is given, the construction is passed to the C&lt;parse&gt;
constructor.

=item new( 'foo', '1.4' )

Two arguments are interpreted as package name and version. The relation is
assumed to be '&gt;='.

=item new( 'foo', '=', '42' )

Three arguments are interpreted as package name, relation and version.

=cut

sub new {
    my $class = shift;
    $class = ref($class) if ref($class);

    my $self = $class-&gt;SUPER::new();
    my( $pkg, $rel, $ver );

    if( ref($_[0]) and ref($_[0]) eq 'HASH' ) {
        $pkg = delete $_[0]-&gt;{pkg};
        $rel = delete $_[0]-&gt;{rel} // '&gt;=';
        $ver = delete $_[0]-&gt;{ver};
        # pass-through the rest
        while( my($k,$v) = each %{$_[0]} ) {
            $self-&gt;$k($v);
        }
    }
    elsif( ref($_[0]) and ref($_[0]) eq 'ARRAY' ) {
        $self-&gt;alternatives(
            [ map { $self-&gt;new($_) } @{ $_[0] } ],
        );

        for( @{ $self-&gt;alternatives } ) {
            croak "Alternatives can't be nested"
                if $_-&gt;alternatives;
        }

        return $self;
    }
    elsif( @_ == 1 ) {
        return $class-&gt;parse($_[0]);
    }
    elsif( @_ == 2 ) {
        $pkg = shift;
        $rel = '&gt;=';
        $ver = shift;
    }
    elsif( @_ == 3 ) {
        ( $pkg, $rel, $ver ) = @_;
    }
    else {
        die "Unsupported number of arguments";
    }

    $self-&gt;ver($ver);

    unless( defined( $self-&gt;ver ) ) {
        undef($rel);
        delete $self-&gt;{ver};
    };

    if ($rel) {
        $rel = '&lt;=' if $rel eq '&lt;';
        $rel = '&gt;=' if $rel eq '&gt;';
        $self-&gt;rel($rel);
    }

    croak "pkg is mandatory" unless $pkg or $self-&gt;alternatives;

    $self-&gt;pkg($pkg);

    return $self;
}

sub _stringify {
    my $self = shift;

    if( $self-&gt;alternatives ) {
        return join( ' | ', @{ $self-&gt;alternatives } );
    }

    return (
          $self-&gt;ver
        ? $self-&gt;pkg . ' (' . $self-&gt;rel . ' ' . $self-&gt;ver . ')'
        : $self-&gt;pkg
    );
}

sub _add {
    my $left = shift;
    my $right = shift;
    my $mode = shift;

    confess "cannot += Dependency. put Dependencies instance on the left instead" unless defined($mode);

    return bless( [ $left ], 'Debian::Dependencies' ) + $right;
}

our %rel_order = (
    '&lt;&lt;'    =&gt; -2,
    '&lt;='    =&gt; -1,
    '='     =&gt; 0,
    '&gt;='    =&gt; +1,
    '&gt;&gt;'    =&gt; +2,
);

sub _compare {
    my( $left, $right ) = @_;

    if( $left-&gt;alternatives ) {
        if( $right-&gt;alternatives ) {
            my @pairs = mesh(
                @{ $left-&gt;alternatives }, @{ $right-&gt;alternatives },
            );

            while(@pairs) {
                my( $l, $r ) = splice @pairs, 0, 2;

                return -1 unless $l;
                return 1 unless $r;
                my $res = _compare( $l, $r );
                return $res if $res;
            }

            return 0;
        }
        else {
            my $res = _compare( $left-&gt;alternatives-&gt;[0], $right );
            return $res if $res;
            return 1;
        }
    }
    else {
        if( $right-&gt;alternatives ) {
            my $res = _compare( $left, $right-&gt;alternatives-&gt;[0] );
            return $res if $res;
            return -1;
        }
        else {
            # nothing, the code below compares two plain dependencies
        }
    }

    my $res = $left-&gt;pkg cmp $right-&gt;pkg;

    return $res if $res != 0;

    return -1 if not defined( $left-&gt;ver ) and defined( $right-&gt;ver );
    return +1 if defined( $left-&gt;ver ) and not defined( $right-&gt;ver );

    return 0 unless $left-&gt;ver; # both have no version

    $res = $left-&gt;ver &lt;=&gt; $right-&gt;ver;

    return $res if $res != 0;

    # same versions, compare relations
    return $rel_order{ $left-&gt;rel } &lt;=&gt; $rel_order{ $right-&gt;rel };
}

=item set

Overrides the set method from L&lt;Class::Accessor&gt;. Used to convert zero versions
(for example I&lt;0&gt; or I&lt;0.000&gt;) to void versions.

=cut

sub set {
    my( $self, $field, $value ) = @_;

    undef($value)
    if $field eq 'ver'
        and defined($value)
        and $value =~ /^0[0.]*$/;

    $value = Dpkg::Version-&gt;new( $value, check =&gt; 1 )
        if $field eq 'ver' and defined($value);

    $self-&gt;SUPER::set( $field, $value );
}

=item parse()

Takes a single string argument and parses it.

Examples:

=over

=item perl

=item perl (&gt;= 5.8)

=item libversion-perl (&lt;&lt; 3.4)

=back

=cut

sub parse {
    my ( $class, $str ) = @_;

    if( $str =~ /\|/ ) {
        # alternative dependencies
        return $class-&gt;new( {
            alternatives =&gt; [
                map { $class-&gt;new($_) } split( /\s*\|\s*/, $str )
            ],
        } );
    }

    if ($str =~ m{
            ^               # start from the beginning
            \s*             # stray space
            ([^\(\s]+)      # package name - no paren, no space
            \s*             # optional space
            (?:             # version is optional
                \(          # opening paren
                    (       # various relations 
                        &lt;&lt;
                      | &lt;=
                      | =
                      | &gt;=
                      | &gt;&gt;
                      | &lt;
                      | &gt;
                    )
                    \s*     # optional space
                    (.+)    # version
                \)          # closing paren
            )?
            \s*             # optional space
            (?:             # architecture is optional
                \[
                    (?:
                        !?             # negation is optional
                        [^\s\]]+       # architecture name
                        (?:\s+|(?=\])) # whitespace or end
                    )+
                \]
            )?
            $}x    # done
        )
    {
        return $class-&gt;new(
            {   pkg =&gt; $1,
                (     ( defined($2) and defined($3) )
                    ? ( rel =&gt; $2, ver =&gt; $3 )
                    : ()
                )
            }
        );
    }
    else {
        die "Unable to parse '$str'";
    }
}

1;

=back

=head2 FIELDS

=over

=item pkg

Contains the name of the package that is depended upon

=item rel

Contains the relation of the dependency. May be any of '&lt;&lt;', '&lt;=', '=', '&gt;='
or '&gt;&gt;'. Default is '&gt;='.

=item ver

Contains the version of the package the dependency is about. The value is an
instance of L&lt;Dpkg::Version&gt; class. If you set it to a scalar value, that is
given to L&lt;Dpkg::Version&gt;-&gt;new().

=back

C&lt;rel&gt; and C&lt;ver&gt; are either both present or both missing.

Examples

    print $dep-&gt;pkg;
    $dep-&gt;ver('3.4');

=head1 METHODS

=over

=item satisfies($dep)

Returns true if I&lt;$dep&gt; states a dependency that is already covered by this
instance. In other words, if this method returns true, any package satisfying
the dependency of this instance will also satisfy I&lt;$dep&gt; ($dep is redundant in
dependency lists where this instance is already present).

I&lt;$dep&gt; can be either an instance of the L&lt;Debian::Dependency&gt; class, or a
plain string.

    my $dep  = Debian::Dependency-&gt;new('foo (&gt;= 2)');
    print $dep-&gt;satisfies('foo') ? 'yes' : 'no';             # no
    print $dep-&gt;satisfies('bar') ? 'yes' : 'no';             # no
    print $dep-&gt;satisfies('foo (&gt;= 2.1)') ? 'yes' : 'no';    # yes

=cut

sub satisfies {
    my( $self, $dep ) = @_;

    $dep = Debian::Dependency-&gt;new($dep)
        unless ref($dep);

    # we have alternatives? then we satisfy the dependency only if
    # all of the alternatives satisfy it
    if( $self-&gt;alternatives ) {
        for( @{ $self-&gt;alternatives } ) {
            return 0 unless $_-&gt;satisfies($dep);
        }

        return 1;
    }

    # $dep has alternatives? then we satisfy it if we satisfy any of them
    if( $dep-&gt;alternatives ) {
        for( @{ $dep-&gt;alternatives } ) {
            return 1 if $self-&gt;satisfies($_);
        }

        return 0;
    }

    # different package?
    return 0 unless $self-&gt;pkg eq $dep-&gt;pkg;

    # $dep has no relation?
    return 1 unless $dep-&gt;rel;

    # $dep has relation, but we don't?
    return 0 if not $self-&gt;rel;

    # from this point below both $dep and we have relation (and version)
    my $cmpver = ( $self-&gt;ver &lt;=&gt; $dep-&gt;ver );

    if( $self-&gt;rel eq '&gt;&gt;' ) {
        # &gt;&gt; 4 satisfies also &gt;&gt; 3
        return 1 if $dep-&gt;rel eq '&gt;&gt;'
            and $cmpver &gt;= 0;

        # &gt;&gt; 4 satisfies &gt;= 3 and &gt;= 4
        return 1 if $dep-&gt;rel eq '&gt;='
            and $cmpver &gt;= 0;

        # &gt;&gt; 4 can't satisfy =, &lt;= and &lt;&lt; relations
        return 0;
    }
    elsif( $self-&gt;rel eq '&gt;=' ) {
        # &gt;= 4 satisfies &gt;= 3
        return 1 if $dep-&gt;rel eq '&gt;='
            and $cmpver &gt;= 0;

        # &gt;= 4 satisvies &gt;&gt; 3, but not &gt;&gt; 4
        return 1 if $dep-&gt;rel eq '&gt;&gt;'
            and $cmpver &gt; 0;

        # &gt;= 4 can't satosfy =, &lt;= and &lt;&lt; relations
    }
    elsif( $self-&gt;rel eq '=' ) {
        return 1 if $dep-&gt;rel eq '='
            and $cmpver == 0;

        # = 4 also satisfies &gt;= 3 and &gt;= 4
        return 1 if $dep-&gt;rel eq '&gt;='
            and $cmpver &gt;= 0;

        # = 4 satisfies &gt;&gt; 3, but not &gt;&gt; 4
        return 1 if $dep-&gt;rel eq '&gt;&gt;'
            and $cmpver &gt; 0;

        # = 4 satisfies &lt;= 4 and &lt;= 5
        return 1 if $dep-&gt;rel eq '&lt;='
            and $cmpver &lt;= 0;

        # = 4 satisfies &lt;&lt; 5, but not &lt;&lt; 4
        return 1 if $dep-&gt;rel eq '&lt;&lt;'
            and $cmpver &lt; 0;

        # other cases mean 'no'
        return 0;
    }
    elsif( $self-&gt;rel eq '&lt;=' ) {
        # &lt;= 4 satisfies &lt;= 5
        return 1 if $dep-&gt;rel eq '&lt;='
            and $cmpver &lt;= 0;

        # &lt;= 4 satisfies &lt;&lt; 5, but not &lt;&lt; 4
        return 1 if $dep-&gt;rel eq '&lt;&lt;'
            and $cmpver &lt; 0;

        # &lt;= 4 can't satisfy =, &gt;= and &gt;&gt;
        return 0;
    }
    elsif( $self-&gt;rel eq '&lt;&lt;' ) {
        # &lt;&lt; 4 satisfies &lt;&lt; 5
        return 1 if $dep-&gt;rel eq '&lt;&lt;'
            and $cmpver &lt;= 0;

        # &lt;&lt; 4 satisfies &lt;= 5 and &lt;= 4
        return 1 if $dep-&gt;rel eq '&lt;='
            and $cmpver &lt;= 0;

        # &lt;&lt; 4 can't satisfy =, &gt;= and &gt;&gt;
        return 0;
    }
    else {
        croak "Should not happen: $self satisfies $dep?";
    }
}

=back

=head1 SEE ALSO

L&lt;Debian::Dependencies&gt;

=head1 AUTHOR

=over 4

=item Damyan Ivanov &lt;dmn@debian.org&gt;

=back

=head1 COPYRIGHT &amp; LICENSE

=over 4

=item Copyright (C) 2008,2009,2010 Damyan Ivanov &lt;dmn@debian.org&gt;

=back

This program is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License version 2 as published by the Free
Software Foundation.

This program is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE.  See the GNU General Public License for more details.

You should have received a copy of the GNU General Public License along with
this program; if not, write to the Free Software Foundation, Inc., 51 Franklin
Street, Fifth Floor, Boston, MA 02110-1301 USA.

=cut
</pre></body></html>