117 lines
3 KiB
Perl
117 lines
3 KiB
Perl
|
# $OpenBSD: Utils.pm,v 1.7 2020/07/11 22:26:01 abieber Exp $
|
||
|
|
#
|
||
|
|
# Copyright (c) 2015 Giannis Tsaraias <tsg@openbsd.org>
|
||
|
|
#
|
||
|
|
# Permission to use, copy, modify, and distribute this software for any
|
||
|
|
# purpose with or without fee is hereby granted, provided that the above
|
||
|
|
# copyright notice and this permission notice appear in all copies.
|
||
|
|
#
|
||
|
|
# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
|
||
|
|
# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
|
||
|
|
# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
|
||
|
|
# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
|
||
|
|
# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
|
||
|
|
# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
|
||
|
|
# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
|
||
|
|
|
||
|
|
package OpenBSD::PortGen::Utils;
|
||
|
|
|
||
|
|
use 5.012;
|
||
|
|
use warnings;
|
||
|
|
use feature qw( state );
|
||
|
|
|
||
|
|
use parent qw( Exporter );
|
||
|
|
|
||
|
|
our @EXPORT_OK = qw(
|
||
|
|
add_to_new_ports
|
||
|
|
base_dir
|
||
|
|
fetch
|
||
|
|
module_in_ports
|
||
|
|
ports_dir
|
||
|
|
);
|
||
|
|
|
||
|
|
sub _fetch_cmd { $ENV{'FETCH_CMD'} || '/usr/bin/ftp' }
|
||
|
|
|
||
|
|
sub fetch
|
||
|
|
{
|
||
|
|
my $url = shift;
|
||
|
|
|
||
|
|
for ( 0 .. 1 ) {
|
||
|
|
open my $fh, '-|', _fetch_cmd() . " -o- $url 2> /dev/null" or die $!;
|
||
|
|
my $content = do { local $/ = undef; <$fh> };
|
||
|
|
return $content if $content;
|
||
|
|
sleep 2 * $_;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
sub ports_dir { $ENV{PORTSDIR} || '/usr/ports' }
|
||
|
|
|
||
|
|
sub base_dir { ports_dir() . '/mystuff' }
|
||
|
|
|
||
|
|
sub _module_sth
|
||
|
|
{
|
||
|
|
my $dbfile = '/usr/local/share/sqlports';
|
||
|
|
die "install databases/sqlports and databases/p5-DBD-SQLite\n"
|
||
|
|
unless -e $dbfile;
|
||
|
|
|
||
|
|
require DBI; # do this here after we've checked for $dbfile
|
||
|
|
|
||
|
|
my $dbh = DBI->connect( "dbi:SQLite:dbname=$dbfile", "", "", {
|
||
|
|
ReadOnly => 1,
|
||
|
|
RaiseError => 1,
|
||
|
|
} ) or die "failed to connect to database: $DBI::errstr";
|
||
|
|
|
||
|
|
return $dbh->prepare(q{
|
||
|
|
SELECT _Paths.FullPkgPath FROM _Paths
|
||
|
|
JOIN _Ports ON _Paths.PkgPath = _Ports.FullPkgPath
|
||
|
|
WHERE PKGSTEM = ?
|
||
|
|
AND _Paths.Id = _Paths.PkgPath
|
||
|
|
ORDER BY LENGTH(_Paths.FullPkgPath)
|
||
|
|
});
|
||
|
|
}
|
||
|
|
|
||
|
|
sub module_in_ports
|
||
|
|
{
|
||
|
|
my ( $module, $prefix ) = @_;
|
||
|
|
return unless $module and defined $prefix;
|
||
|
|
|
||
|
|
state $sth = _module_sth();
|
||
|
|
END { undef $sth }; # Bus error if destroyed during global destruction
|
||
|
|
|
||
|
|
my @stems = ( $prefix . $module );
|
||
|
|
|
||
|
|
# We commonly convert the port to lowercase
|
||
|
|
push @stems, $prefix . lc($module) if $module =~ /\p{Upper}/;
|
||
|
|
|
||
|
|
foreach my $stem (@stems) {
|
||
|
|
$sth->execute($stem);
|
||
|
|
my ($path, @extra) = map {@$_} @{ $sth->fetchall_arrayref };
|
||
|
|
warn "Found paths other than $path: @extra\n"
|
||
|
|
if @extra;
|
||
|
|
return $path if $path;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Many ports, in particular python ports, start with $prefix,
|
||
|
|
# possibly without the "-". To catch that, we check if
|
||
|
|
# e.g. pytest got imported as py-test instead of py-pytest
|
||
|
|
( my $start = $prefix ) =~ s/-$//;
|
||
|
|
|
||
|
|
return unless $start;
|
||
|
|
|
||
|
|
if ( $module =~ /^$start-?(.*)$/ ) {
|
||
|
|
return module_in_ports( $1, $prefix );
|
||
|
|
}
|
||
|
|
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
# i know, i know...
|
||
|
|
sub add_to_new_ports
|
||
|
|
{
|
||
|
|
state @new_ports;
|
||
|
|
push @new_ports, shift;
|
||
|
|
return @new_ports;
|
||
|
|
}
|
||
|
|
|
||
|
|
1;
|