File Coverage

blib/lib/Slackware/SBoKeeper/Database.pm

Criterion	Covered	Total	%
statement	248	261	95.0
branch	54	74	72.9
condition	8	14	57.1
subroutine	32	32	100.0
pod	23	25	92.0
total	365	406	89.9

package Slackware::SBoKeeper::Database;
use 5.016;
our $VERSION = '2.06';
use strict;
use warnings;

use List::Util qw(any uniq);

sub write_data {

	my $data = shift;
	my $out  = shift;

	my $outstr = '';

	open my $fh, '>', $out // \$outstr
		or die sprintf "Failed to open %s for writing: $!\n", $out // 'in-memory scalar';

	foreach my $p (sort keys %{$data}) {

		say { $fh } "PACKAGE: $p";
		say { $fh } "DEPS: ", join(' ', @{$data->{$p}->{Deps}});
		say { $fh } "MANUAL: $data->{$p}->{Manual}";
		say { $fh } '%%';

	}

	close $fh;

	return $out // $outstr;

}

sub read_data {

	my $file      = shift;
	my $blacklist = shift // {};

	my $data = {};

	open my $fh, '<', $file or die "Failed to open $file for reading: $!\n";

	my $pkg = '';
	my $lnum = 1;

	while (my $l = readline $fh) {

		chomp $l;

		if ($l eq '%%') {
			$pkg = '';
		} elsif ($l =~ /^PACKAGE: /) {
			$pkg = $l =~ s/^PACKAGE: //r;
			$data->{$pkg} = {};
		} elsif ($pkg eq '') {
			die "Bad line in $file at line $lnum: PACKAGE not set\n";
		} elsif ($l =~ /^DEPS: /) {
			my $depstr = $l =~ s/^DEPS: //r;
			@{$data->{$pkg}->{Deps}} =
				grep { not exists $blacklist->{$_} }
				split /\s/, $depstr;
		} elsif ($l =~ /^MANUAL: /) {
			my $manual = $l =~ s/^MANUAL: //r;
			$data->{$pkg}->{Manual} = $manual eq '1' ? 1 : 0;
		} else {
			die "Bad line in $file at line $lnum\n";
		}

		$lnum++;

	}

	close $fh;

	# Weed out blacklisted packages
	for my $p (keys %{$blacklist}) {
		delete $data->{$p};
	}

	return $data;

}

sub new {

	my $class     = shift;
	my $file      = shift;
	my $sbodir    = shift;
	my $blacklist = shift // {};

	$blacklist->{'%README%'} = 1;

	my $self = {
		_data      => {},
		_sbodir    => '',
		_blacklist => $blacklist,
	};

	if ($file) {
		$self->{_data} = read_data($file, $self->{_blacklist});
	}

	$self->{_sbodir} = $sbodir;

	bless $self, $class;
	return $self;

}

sub add {

	my $self   = shift;
	my $pkgs   = shift;
	my $manual = shift;

	my %added;
	my $n = 0;

	foreach my $p (@{$pkgs}) {

		next if $self->blacklist($p);

		unless ($self->exists($p)) {
			die "$p does not exist in SlackBuild repo\n";
		}

		# pkg already present, do not add. Set manual flag if desired.
		if (defined $self->{_data}->{$p}) {
			$self->{_data}->{$p}->{Manual} = $manual if $manual;
			next;
		}

		$self->{_data}->{$p}->{Manual} = $manual;

		my @deps = $self->real_immediate_dependencies($p);
		$self->{_data}->{$p}->{Deps} = \@deps;

		my @add = $self->add($self->{_data}->{$p}->{Deps}, 0);

		for my $ad (@add) {
			$added{$ad} = $n++ unless exists $added{$ad};
		}

		$added{$p} = $n++;

	}

	return sort { $added{$a} <=> $added{$b} } keys %added;

}

sub tack {

	my $self   = shift;
	my $pkgs   = shift;
	my $manual = shift;

	my @tack;

	foreach my $p (@{$pkgs}) {

		next if $self->blacklist($p);

		unless ($self->exists($p)) {
			die "$p does not exist in SlackBuild repo\n";
		}

		if (defined $self->{_data}->{$p} and $manual) {
			$self->{_data}->{$p}->{Manual} = $manual;
			push @tack, $p;
		} else {
			$self->{_data}->{$p} = {
				Deps   => [],
				Manual => $manual,
			};
			push @tack, $p;
		}

	}

	return @tack;

}

sub remove {

	my $self = shift;
	my $pkgs = shift;

	my @rm;

	foreach my $p (@{$pkgs}) {

		unless (defined $self->{_data}->{$p}) {
			warn "$p not present in database, not removing\n";
			next;
		}

		delete $self->{_data}->{$p};

		push @rm, $p;

	}

	return sort @rm;

}

sub depadd {

	my $self = shift;
	my $pkg  = shift;
	my $deps = shift;

	unless ($self->has($pkg)) {
		die "$pkg is not present in database\n";
	}

	my @add;
	foreach my $d (@{$deps}) {

		next if $self->blacklist($d);

		unless ($self->has($d)) {
			warn "$d not present in database, skipping\n";
			next;
		}

		unless (any { $d eq $_ } @{$self->{_data}->{$pkg}->{Deps}}) {
			push @{$self->{_data}->{$pkg}->{Deps}}, $d;
			push @add, $d;
		}

	}

	return @add;

}

sub depremove {

	my $self = shift;
	my $pkg  = shift;
	my $deps = shift;

	my @kept;
	my @rm;
	foreach my $p (@{$self->{_data}->{$pkg}->{Deps}}) {
		if (any { $p eq $_ } @{$deps}) {
			push @rm, $p;
		} else {
			push @kept, $p;
		}
	}

	$self->{_data}->{$pkg}->{Deps} = \@kept;

	return @rm;

}

sub has {

	my $self = shift;
	my $pkg  = shift;

	return defined $self->{_data}->{$pkg};

}

sub packages {

	my $self = shift;

	return sort keys %{$self->{_data}};

}

sub missing {

	my $self = shift;

	my %missing;

	foreach my $p ($self->packages) {

		my @pmissing =
			grep { !$self->has($_) }
			$self->real_immediate_dependencies($p);

		push @{$missing{$p}}, @pmissing if @pmissing;

	}

	return %missing;

}

sub extradeps {

	my $self = shift;

	my @pkgs = $self->packages;

	my %extra;

	foreach my $p (@pkgs) {

		my %realdeps = map { $_ => 1 } $self->real_immediate_dependencies($p);

		my @pextra =
			grep { !defined $realdeps{$_} }
			$self->immediate_dependencies($p);

		push @{$extra{$p}}, @pextra if @pextra;

	}

	return %extra;

}

sub is_necessary {

	my $self = shift;
	my $pkg  = shift;

	unless (defined $self->{_data}->{$pkg}) {
		return 0;
	}

	if ($self->{_data}->{$pkg}->{Manual}) {
		return 1;
	}

	# Check if $pkg is a dependency of any manually installed package

	return
		any { $self->is_dependency($pkg, $_) }
		grep { $self->is_manual($_) }
		$self->packages
	;

}

sub is_dependency {

	my $self = shift;
	my $dep  = shift;
	my $of   = shift;

	foreach my $p (@{$self->{_data}->{$of}->{Deps}}) {

		if ($p eq $dep) {
			return 1;
		}

		if ($self->is_dependency($dep, $p)) {
			return 1;
		}

	}

	return 0;

}

sub is_immediate_dependency {

	my $self = shift;
	my $dep  = shift;
	my $of   = shift;

	foreach my $p (@{$self->{_data}->{$of}->{Deps}}) {
		if ($p eq $dep) {
			return 1;
		}
	}

	return 0;

}

sub is_manual {

	my $self = shift;
	my $pkg  = shift;

	return $self->{_data}->{$pkg}->{Manual} ? 1 : 0;

}

sub exists {

	my $self = shift;
	my $pkg  = shift;

	return 0 if $self->blacklist($pkg);

	if (() = glob "$self->{_sbodir}/*/$pkg/$pkg.info") {
		return 1;
	} else {
		return 0;
	}

}

sub blacklist {

	my $self = shift;
	my $pkg  = shift;

	return exists $self->{_blacklist}->{$pkg};

}

sub dependencies {

	my $self = shift;
	my $pkg  = shift;

	my @deps;

	@deps = $self->immediate_dependencies($pkg);

	foreach my $d (@deps) {
		push @deps, $self->dependencies($d);
	}

	return uniq sort @deps;

}

sub immediate_dependencies {

	my $self = shift;
	my $pkg  = shift;

	return sort @{$self->{_data}->{$pkg}->{Deps}};

}

sub real_dependencies {

	my $self = shift;
	my $pkg  = shift;

	my @deps;

	@deps = $self->real_immediate_dependencies($pkg);

	foreach my $d (@deps) {
		push @deps, $self->real_dependencies($d);
	}

	return uniq sort @deps;

}

sub real_immediate_dependencies {

	my $self = shift;
	my $pkg  = shift;

	my @deps;

	my ($info) = glob "$self->{_sbodir}/*/$pkg/$pkg.info";

	die "Could not find $pkg in $self->{_sbodir}\n" unless $info;

	open my $fh, '<', $info
		or die "Failed to open $info for reading: $!\n";

	while (my $l = readline $fh) {

		chomp $l;

		next unless $l =~ /^REQUIRES=".*("|\\)$/;

		my ($depstr) = $l =~ /^REQUIRES="(.*)("|\\)/;

		@deps = grep { !$self->blacklist($_) } split /\s/, $depstr;

		while (substr($l, -1) eq '\\') {

			$l = readline $fh;
			chomp $l;

			($depstr) = $l =~ /(^.*)("|\\)/;

			push @deps, grep { !$self->blacklist($_) } split(" ", $depstr);

		}

		last;

	}

	close $fh;

	return sort @deps;

}

sub reverse_dependencies {

	my $self = shift;
	my $pkg  = shift;

	return grep {
		$self->is_immediate_dependency($pkg, $_)
	} $self->packages;

}

sub unmanual {

	my $self = shift;
	my $pkg  = shift;

	unless (defined $self->{_data}->{$pkg}) {
		return 0;
	}

	$self->{_data}->{$pkg}->{Manual} = 0;

	return 1;

}

sub write {

	my $self = shift;
	my $path = shift;

	write_data($self->{_data}, $path);

}

1;



=head1 NAME

Slackware::SBoKeeper::Database - Read/write sbokeeper databases

=head1 SYNOPSIS

 use Slackware::SBoKeeper::Database;

 my $database = Slackware::SBoKeeper::Database->new($file, $repo);
 ...

=head1 DESCRIPTION

Slackware::SBoKeeper::Database is a module that handles reading and writing
L package database files. It is not meant to be used outside of
L. For user documentation of L, please consult its manual.

=head1 SUBROUTINES/METHODS

=head2 new($path, $sbodir, [ $blacklist ])

Returns blessed Slackware::SBoKeeper::Database object. $path is the path to a
file containing B data. If $path is '', creates an empty
database. $sbodir is the directory where the SBo repository is stored.

$blacklist is a hash ref of packages to ignore. Defaults to empty hash ref if
no hash is supplied.

=head2 add($pkgs, $manual)

Add array ref of pkgs and their dependencies to object. If $manual is true,
$pkgs are set to manually added (dependencies are still not).

Returns array of packages added.

=head2 tack($pkgs, $manual)

Add array ref of pkgs to database. $manual determines whether they are marked
as manually added or not. Does not pull in dependencies.

Returns array of packages added.

=head2 remove($pkgs)

Remove array ref pkgs from object. Dependencies pulled in from removed packages
will still remain.

Returns array of packages removed.

=head2 depadd($pkg, $deps)

Add array ref $deps to $pkg's dependencies. $deps must be a list of packages
already present in the database.

Returns list of dependencies added to $pkg.

=head2 depremove($pkg, $deps)

Removes array ref $deps from $pkg's dependency list.

Returns list of dependencies removed.

=head2 has($pkg)

Returns 1 or 0 depending on whether $pkg is currently in the database.

=head2 packages()

Returns array of packages present in database.

=head2 missing()

Returns hash of packages and their missing dependencies, according to the
SlackBuild repo.

=head2 extradeps()

Returns hash of packages with extra dependencies. An extra dependency is a
dependency that is not required by the package in the SlackBuild repo.

=head2 is_necessary($pkg)

Checks to see if $pkg is necessary (manually added or dependency on a manually
added package). Returns 1 for yes, 0 for no.

=head2 is_dependency($dep, $of)

Checks to see if $dep is a dependency (or a dependency of a dependency, etc.) of
$of. Returns 1 for yes, 0 for no.

$dep and $of must already be added to the object.

=head2 is_immediate_dependency($dep, $of)

Checks to see if $dep is a dependency of $of. Returns 1 for yes, 0 for no.

$dep and $of must already be added to the object.

=head2 is_manual($pkg)

Checks if $pkg is manually installed. Returns 1 for yes, 0 no.

=head2 exists($pkg)

Checks if $pkg is present in repo. Returns 1 for yes, 0 for no.

=head2 blacklist($pkg)

Checks if $pkg is in the blacklist. Returns 1 for yes, 0 for no.

=head2 dependencies($pkg)

Returns list of packages that are a dependency of $pkg, according to the
database.

=head2 immediate_dependencies($pkg)

Returns list of packages that are an immediate dependency of $pkg, according to
the database. Does not return dependencies of those dependencies.

=head2 real_dependencies($pkg)

Returns list of packages that are a dependency of $pkg, according to the
SlackBuild repo. $pkg does not have to have been added previously.

=head2 real_immediate_dependencies($pkg)

Returns list of packages that are an immediate dependency of $pkg, according
to the SlackBuild repo. Does not return packages that are dependencies of those
dependencies. $pkg does not have to have been added previously.

=head2 reverse_dependencies($pkg)

Returns list of packages that depend on $pkg, according to the sbokeeper
database.

=head2 unmanual($pkg)

Unset $pkg as manually installed. Returns 1 if successful, 0 if not.

=head2 write([$path])

Writes data file to C<$path>, or returns string of would-be written data if
C<$path> is omitted.

=head1 DATA FILES

B data files are text files. Data files contain packages, which are
a series of lines that contain package information ended by a pair of percentage
signs (%%). A package entry should look something like this:

 PACKAGE: libreoffice
 DEPS: avahi zulu-openjdk8
 MANUAL: 1
 %%

=over 4

=item PACKAGE

Name of the package, which must have a corresponding SlackBuild in the
configured SlackBuild repo. This must be the first line in a package entry.

=item DEPS

Whitespace-seperated list of packages that PACKAGE depends on. Each package
must be present in the SlackBuild repo.

=item MANUAL

Specifies whether the package was manually added or not. 1 for yes, 0 for no.

=item %%

Marks the end of the current package entry.

=back

=head1 AUTHOR

Written by Samuel Young [e-mail].

=head1 BUGS

This module does not know how to handle circular dependencies. This should not
be a problem if you stick with the official SlackBuild repo. One should
exercise caution when using the depadd method, as it can easily introduce
circular dependencies.

Report bugs on my Codeberg, L.

=head1 COPYRIGHT

Copyright (C) 2024-2025 Samuel Young

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

=head1 SEE ALSO

L

=cut