path: root/pkgtools/pkg_notify/files/pkg_notify

#! @PERL@

# pkgsrc version upgrade notifier
# covered by the revised BSD license
# iMil <imil@gcu.info>
#
# Create the /usr/pkg/etc/pkg_notify.list file containing the package list
# you want to be informed on, following this format :
#
# $ cat /usr/pkg/etc/pkg_notify.list
# wip/foo
# net/bar
# www/foobar-devel
#
# OR invoke pkg_notify with the package following :
#
# $ pkg_notify category/package
#
# $Id: pkg_notify,v 1.3 2016/08/31 21:15:01 wiz Exp $

use Net::FTP;
use LWP::UserAgent;
use HTTP::Request::Common;
use Getopt::Std;

use strict;

# those three are replaced by Makefile
my $make = "@MAKE@";
my $pkgsrcbase = "@PKGSRCDIR@";
my $localbase = "@PREFIX@";

my $conf = "@PKG_SYSCONFDIR@/pkg_notify.list";

################################################################################

my $extract_sufx = "";
my $distname = "";
my $pkgname = "";
my $version = "";
my $pkgversion = "";
my $dist = "";
my $pkgpath = "";

my $SF_NET= "sourceforge.net";

my $nicearc;
my $go_subdirs;
my $pathvers;

my $debug = 0;

my $subvers = "";

# create an alpha to num mapping
my %alnum = map { $_ => ord($_) - ord('a') + 1 } ('a' .. 'z');

sub dot_strip {
    my $out = $_[0];
    # clean extremities from dots
    $out =~ s/^[\.\-_]+//;
    $out =~ s/[\.\-_]+$//;

    return ($out);
}

sub beta_strip {
    my $out = $_[0];

    # handle beta - alpha - pre...
    if ($out =~ /(.*[0-9])([\-\_\.]?)(pre|alpha|beta|gamma|rc)([0-9]*.*)/i) {
	my $pre = $1;
	my $dev = lc $3;
	# remember real versionning
	$subvers = "$2$3";
	my $post = $4;
	# replace pre|alpha|beta... with equiv nums
	$dev =~ s/([a-z]).*/$alnum{$1}/;
	$out = $pre.".00".$dev."00.".$post;
    }

    return ($out);
}

sub ext_strip {
    # cleanup versions :
    # blah-1.2.3-blah
    # 1.2.3[.-_]pkg -> 1.2.3
    # devel-1.2.3 -> 1.2.3
    my $out = $_[0];

    # version has no chars, should be fine
    if ($out !~ /[a-z]/) {
	return ($out);
    }

    if ($out =~ /^[a-z\-\._]+([0-9\-\._]+)[a-z\-\._]+$/i) {
	# strip (qwerty-)1.2.3(-qwerty)
	$out = $1;
    } elsif ($out =~ /^([0-9\-\._]+)[\-\._][a-z]+/i) {
	# strip 1.2.3(-qwerty)
	$out = $1;
    } elsif ($out =~ /[a-z]+[\-\._]+([0-9\-\._]+)$/i) {
	# strip (qwerty-)1.2.3
	$out = $1;
    }

    return ($out);
}

sub is_beta {
    if ($_[0] =~ /00[0-9]+00/) {
	return (1);
    }
    return (0);
}

sub find_version {
    my @ls = @_;
    my $lastvers = "";
    my $realdist = "";

    foreach (@ls) {
	my $line = $_;
	my $wasbad = 0;

	if ($line =~ /([^0-9a-z]$dist|^$dist)([^\/\"<>\@]+)$extract_sufx/) {

	    $realdist = $dist.$2.$extract_sufx;
	    my $lsvers = $2;

	    # replace alpha|beta|... with .0[num]0.
	    $lsvers = beta_strip($lsvers);

	    # strip any extension left (bin, pkg, src, devel-...)
	    if ($nicearc) {
		$lsvers = ext_strip($lsvers);
	    } else {
		# remember archive was bad for next loop
		$wasbad = 1;
	    }

	    # with beta/alpha/... numbered, archive may be nice
	    if (($lsvers !~ /[^0-9\.\-\_]/i) && 
		($version !~ /[^0-9\.\-\_]/i)) {
		$nicearc = 1;
	    }

	    # replace every dot-like char (-_) with dots
	    $lsvers = dot_strip($lsvers);

	    my $display_lsvers;
	    if ($subvers ne "") {
		# archive has an alpha / beta / ...
		$display_lsvers = $lsvers;
		$display_lsvers =~ s/(\.00[0-9]+00)/$subvers/;
		$subvers = "";
	    } else {
		$display_lsvers = $lsvers;
	    }

	    # replace [-_] with dot
	    $lsvers =~ s/[\-\_]/./g;
	    $version =~ s/[\-\_]/./g;

	    # replace remaining chars
	    # ex: 3.14a -> 3.14.1, i -> 9
	    $lsvers = lc $lsvers;
	    $lsvers =~ s/([a-z])/.$alnum{$1}/g;
	    # numberify official version
	    $version = lc $version;
	    $version =~ s/([a-z])/.$alnum{$1}/g;

	    # uniq .'s
	    $lsvers =~ s/\.+/./g;
	    $version =~ s/\.+/./g;

	    if ($debug) {
		print "comparing $lsvers against $version (nicearc: $nicearc)\n";
	    }

	    if (($lsvers ne $lastvers) && # already seen
		# if it's not a nicearc, do basic string comparison
		# if it is a nicearc, finest / int comparison
		(($lsvers gt $version) | $nicearc)) {

		my $greater = 0;

		if ($nicearc) { # nice archive, has at least major.minor

		    my @pkg_version = split(/[\.\-_]/, $version);
		    my @ls_version = split(/[\.\-_]/, $lsvers);

		    my $i = 0;
		    foreach (@ls_version) {

			# package version has this member
			if (defined($pkg_version[$i])) {

			    my $member = $_;

			    # empty member
			    if ($member =~ /^$/) {
				last;
			    }
			    # archive version has non-num in it, can't compare
			    if ($member =~ /[^0-9]/) {
				last;
			    }
			    # is this member greater that pkg_version equiv ?
			    if ($member > $pkg_version[$i]) {
				# if member is beta, version is >
				if (is_beta($member) && 
				    !is_beta($pkg_version[$i])) {
				    last;
				}
				$greater = 1;
				last;
			    }

			    # local package has a superior version, end
			    if ($pkg_version[$i] > $member) {
				# if version is beta, member is >
				if (!is_beta($member) &&
				    is_beta($pkg_version[$i])) {
				    $greater = 1;
				}
				last;
			    }

			} else { # package version don't have this sub-number
			    if (!is_beta($_)) { # avoid beta versions
				# aka 1.1.1beta !> 1.1.1
				$greater = 1;
			    }
			    last;
			}

			$i++; # increment version member
		    } # foreach

		}
		if ($nicearc == 0) { # not a nice distname
		    $greater = 1;
		}
		# strip \'s
		$realdist =~ s/\\//g;
		if ($greater) {
		    print "!! seems like there's a new version for $pkgname\n";
		    print "!! [v.$display_lsvers] - from $realdist\n";
		    $lastvers = $lsvers;
		}
	    }
	} # if line /arc/
	if ($wasbad) { # remember, archive was bad
	    $nicearc = 0;
	}
    } # foreach @ls
    if ($lastvers eq "") {
	return (0);
    } else {
	return (1);
    }
}

my $ftp;

sub ftp_connect {

    if ($ftp = Net::FTP->new($_[0], Debug => 0, Passive => 1)) {

	if ($ftp->login("anonymous",'-anonymous@')) {
	    # connected
	    return (1);
	} else { 
	    if ($debug) {
		print "Cannot login ", $ftp->message;
	    }
	    return (0);
	}

    } else {
	if ($debug) {
	    print "Cannot connect to site: $@\n";
	}
    }
}

my $hadversion = 0;
# maximum ftp recursion
my $max_recurs = 3;
my $nb_recurs;

sub ftp_ls {

    my $path = $_[0];

    # first connection
    if (!defined($ftp)) {

	my $site = $_[0];
	$path = "/";

	$site =~ s/(ftp:\/\/)([^\/]+)(\/?.*)/$2/;
	$path = $3;

	if (!ftp_connect($site)) {
	    return (0)
	}
    }

    if ($nb_recurs > $max_recurs) {
	return (0);
    } else {
	$nb_recurs++;
    }

    # don't recurse to yourself
    if ($path =~ /\.\ ?\//) {
	return (0);
    }

    my @list;
    if (my @ls = $ftp->dir($path)) {

	foreach (@ls) {
	    chomp;
	    
	    my $relpath = $_;
	    $relpath =~ s/.*[\t\ ](.+)$/$1/;

	    my $type = substr($_, 0, 1);

	    # recurse
	    if ($type eq 'd') {

		ftp_ls("$path/$relpath");
		# back from child directory, decrement recursion
		$nb_recurs--;

	    } else {
		push(@list, "$relpath");
	    }
	}
	# could not cwd
    } else {
	if ($debug) {
	    print "Cannot change working directory ", $ftp->message;
	}
    }

    # remember when we have found something
    if (find_version(@list)) {
	$hadversion = 1;
    }

    return ($hadversion);
}

sub http_ls {
    my $ua = LWP::UserAgent->new(agent => 'pkg_notify');

    my @page = "";
    my $site = $_[0];

    my $headers = $ua->head($site);

    if ($headers) {
	if ($headers->content_type !~ /text/) {
	    print " * $site is a direct download !\n";
	    return (0);
	}
    } else {
	print " ** $site has no HTTP headers !\n";
	return (0);
    }

    my $reply = $ua->get($site);

    if ($reply->is_success) {
	@page = split("\n", $reply->content);

	if ($go_subdirs) {
	    $go_subdirs = 0;
	    foreach (@page) {
		chomp;

		my $pattern = $pathvers;
		$pattern =~ s/.*\/([a-z]+)[\/\.\-_0-9]+$/$1/i;

		if (/$pattern/) {

		    my $lsvers = $_;
		    $lsvers  =~ s/.*a\ href\=\"([^\"\ ]+?)\".*/$1/i;

		    # both are / terminated
		    if ($lsvers =~ /[^\/]$/) {
			$lsvers = $lsvers ."/";
		    }
		    if ($pathvers =~ /[^\/]$/) {
			$pathvers = $pathvers ."/";
		    }

		    $lsvers = "$site/$lsvers";

		    if ($lsvers ge $pathvers) {
			http_ls($lsvers);
		    }
		}
	    } # foreach page
	} # if subdirs

	if (find_version(@page)) {
	    return (1);
	} else {
	    return (0);
	}
    } else {
	if ($debug) {
	    print $reply->status_line;
	}
    }
}

# read a file and return array
sub readfile {

    open(FILE, $_[0]) || die "$_[0] not found";
    my @ret = <FILE>;
    close(FILE);

    return (@ret);
}

# match $match against a whole file
sub file_rx_check {

    my $match = $_[1];
    my $flat = join('\n', readfile($_[0]));

    if ($flat =~ /$match/) {
	return (1);
    } else {
	return (0);
    }
}

my @packages;

my %opts;
exit(2) if !getopts('c:', \%opts);
$conf = $opts{c} if defined($opts{c});
if ($#ARGV > -1) {
    @packages = @ARGV; 
} else {
    @packages = readfile($conf);
}

# load MASTER_SORT suffixes
my $master_sort_flat = `cd $pkgsrcbase/pkgtools/pkg_chk && $make show-var VARNAME=MASTER_SORT`;
chomp($master_sort_flat);
my @master_sort_list = reverse(split(/[\ \t]+/, $master_sort_flat));
my @master_list;

sub sort_master_sites {
    my $m_list = $_[0];
    my @s_list = ();

    @master_list = ();

    if ($m_list =~ /$SF_NET/) {
	# we only want ftp sites from SF
	$m_list =~ s/https?:\/\/[^\t\ \n]+//g;
	$m_list =~ s/[\t\ \r\n]+//g;
    }

    # graphics/libggi packages-like fix (ftp://blahhttp://bleh): missing space
    # this is because of previous SF's char stripping
    $m_list =~ s/([^\ ])(ftp\:|http\:|https\:)/$1\ $2/g;

    foreach (@master_sort_list) {
	if ($m_list =~ /(.*)(http|https|ftp)(\:\/\/[^\t\ ]*$_[^\t\ ]*)(.*)/) {
	    push @s_list, $2.$3;
	    $m_list = $1 . $4;
	}
    }
    @s_list = reverse @s_list;
    push @master_list, @s_list;
    push @master_list, split(/[\ \t]+/, $m_list);

    @master_list = reverse @master_list;
}

# used to record last connection
my $last_master_host = "";

foreach (@packages) {
    chomp;

    # ignore comments and newlines
    if (/^[#\n]/) {
	next;
    }

    my $pkg = $_;
    my $master_site;

    $pkgpath = "$pkgsrcbase/$pkg/";

    $pkgname = `cd $pkgpath && $make show-var VARNAME=PKGNAME`;
    chomp($pkgname);

    $pkgversion = $pkgname;
    $pkgversion =~ s/(.+)\-([0-9a-z_\.]+)$/$2/;
    $pkgname = $1;
    $pkgversion =~ s/nb[0-9]+$//;

    my ($major, $minor) = split(/\./, $pkgversion);

    chomp($distname = `cd $pkgpath && $make show-var VARNAME=DISTNAME`);

    # will we strip version numbers from extensions ?
    my $nostrip = 0;

    $nicearc = 0;
    # nice archive, has a comprehensive versioning
    if (defined($minor) && ($distname =~ /(.+?)($major[\._]?$minor.*$)/)) {
	$dist = $1;
	$version = $2;
	$nicearc = 1;
	# archive appears to only have a major
    } elsif (defined($major) && ($distname =~ /(.+)($major.*)/)) {
	$dist = $1;
	$version = $2;
	# ok, archive versioning is a pure mess
	# assume version is everything not being PKGNAME
    } else {
	$dist = $pkgname;
	$version = $distname;
	$version =~ s/$pkgname//;

	# don't strip extensions
	$nostrip = 1;
    }

    # MASTER_SITES is MASTER_SITE_LOCAL, skip
    if (file_rx_check("$pkgpath/Makefile",
		      "MASTER_SITES.+MASTER_SITE_LOCAL")) {
	next;
    }

    # extract HOMEPAGE
    my $homepage = `cd $pkgpath && $make show-var VARNAME=HOMEPAGE`;
    chomp($homepage);

    # extract 1st MASTER_SITE from list
    my $master_flat_list = `cd $pkgpath && $make show-var VARNAME=MASTER_SITES`;
    chomp($master_flat_list);

    sort_master_sites($master_flat_list);

  next_master_site:

    $master_site = pop @master_list;
    if (!$master_site) {
	next;
    }
    chomp($master_site);

    # sourceforge archive
    if ($master_site =~ /$SF_NET.+\/(.+)\/?$/) {
	# SF ftp is hashed
	my $sfpkgdir = $1;
	my $hash = substr($sfpkgdir, 0, 1)."/".substr($sfpkgdir, 0, 2);
	$master_site =~ s/(.+sourceforge)\/.*/$1/;
	$master_site = $master_site."/".$hash."/$sfpkgdir";
    }

    if (($distname eq "") || ($master_site eq "")) {
	print "missing DISTNAME or MASTER_SITES for package $pkgname\n";
	next;
    }

    $version = dot_strip($version);

    my $vers_display = $version;
    if ($vers_display eq "") {
	$vers_display = "none";
    }

    $version = beta_strip($version);

    # strip extensions
    if ($nostrip == 0) {
	$version = ext_strip($version);
    }

    print "- checking for newer version of $pkg\n";
    print " \\ actual distname version: $vers_display\n";
    print " \\ master site: $master_site\n";

    $extract_sufx = `cd $pkgpath && $make show-var VARNAME=EXTRACT_SUFX`;
    chomp($extract_sufx);

    # protect special chars
    $dist =~ s/([\+\-\[\]\{\}\.\*])/\\$1/g;

    $go_subdirs = 0;
    $pathvers = "";

    # try HOMEPAGE first
    my $found = 0;
    if ($homepage ne "") {
	print " \\ homepage: $homepage\n";
	$found = http_ls($homepage, $distname);
    }

    # homepage had no infos, fallback to MASTER_SITES
    if ($found == 0) {

	# check if version exists on MASTER_SITES so we strip it
	# typically ftp://ftp.gnome.org/pub/GNOME/sources/gnome-core/1.4
	if ($nicearc) {
	    $pathvers = $version;
	    $pathvers =~ s/([0-9]+[\-_\.][0-9]+)([\-_\.][0-9]+)*/$1/;
	    # strip master_site to parent
	    if ($master_site =~ /(.+)\/[^\/]*$pathvers.*/) {
		# save full path
		$pathvers = $master_site;
		# base directory
		$master_site = $1;
		$go_subdirs = 1;
	    }
	}

	# ftp master site
	if ($master_site =~ /^ftp\:\/\//) {
	    $nb_recurs = 0;
	    # do not close / reconnect if new ftp site == last ftp site
	    if (($master_site !~ /$last_master_host/) && defined($ftp)) {
		$ftp->quit;
		undef($ftp);
	    }

	    ftp_ls($master_site, $distname);
	    $last_master_host = $master_site;
	    $last_master_host =~ s/(ftp:\/\/[^\/]+).*/$1/;

	    if (!defined($ftp)) {
		print "  /!\\ there was an error while connecting to $master_site\n";
		# believe me you prefer see this than a while / break
		goto next_master_site;
	    }

	    # http master site
	} elsif ($master_site =~ /^https?\:\/\//) {
	    http_ls($master_site, $distname);
	} else {
	    print "unsupported MASTER_SITES protocol";
	}
    }

} # foreach package

# if there was a resient ftp connexion, close it
if (defined($ftp)) {
    $ftp->quit;
}