File Coverage

perllib/Arch/Util.pm

Criterion	Covered	Total	%
statement	101	139	72.6
branch	52	104	50.0
condition	17	42	40.4
subroutine	18	21	85.7
pod	14	14	100.0
total	202	320	63.1

# Arch Perl library, Copyright (C) 2004-2005 Mikhael Goikhman
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# 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., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

use 5.005;
use strict;

package Arch::Util;

# import 2 functions for backward compatibility only; remove after summer 2005
use Arch::Backend qw(arch_backend is_baz);

use Exporter;
use vars qw(@ISA @EXPORT_OK);
@ISA = qw(Exporter);
@EXPORT_OK = qw(
	arch_backend is_baz
	run_pipe_from run_cmd run_tla
	is_tla_functional
	load_file save_file
	copy_dir remove_dir setup_config_dir
	standardize_date date2daysago date2age
	parse_creator_email adjacent_revision _parse_revision_descs
);

sub run_pipe_from (@) {
	my $arg0 = shift || die;
	my @args = (split(' ', $arg0), @_);

	@args = ("'" . join("' '", map { s/'/'"'"'/g; $_ } @args) . "'")  # "
		if $] < 5.008;
	print STDERR "executing: '" . join("' '", @args) . "'\n"
		if $ENV{DEBUG} && ("$ENV{DEBUG}" & "\1") ne "\0";

	# perl-5.005 does not pass compilation without "eval"...
	my $pipe_success = $] >= 5.006?
		eval qq{ no warnings; open(PIPE, '-|', \@args) }: open(PIPE, "$args[0]|");
	die "Can't start (@args): $!\n" unless $pipe_success;
	return \*PIPE;
}

# in scalar context return the output string, in list context - list of lines
sub run_cmd (@) {
	my $arg0 = shift || die;
	my @args = (split(' ', $arg0), @_);

	my $pipe = run_pipe_from(@args);
	local $/ = undef unless wantarray;
	my @lines = <$pipe>;
	close($pipe);
	chomp @lines if wantarray;
	return wantarray? @lines: $lines[0] || "";
}

sub run_tla (@) {
	my $arg1 = shift || die;
	unshift @_, $Arch::Backend::EXE, split(' ', $arg1);
	goto \&run_cmd;
}

sub is_tla_functional () {
	eval { run_tla("help --help") } ? 1 : 0;
}

sub load_file ($;$) {
	my $file_name = shift;
	my $content_ref = shift;
	print STDERR "load_file: $file_name\n"
		if $ENV{DEBUG} && ("$ENV{DEBUG}" & "\4") ne "\0";
	open(FILE, "<$file_name") or die "Can't load $file_name: $!\n";
	local $/ = undef;
	my $content = ;
	close(FILE) or die "Can't close $file_name in load: $!\n";
	if ($content_ref) {
		$$content_ref = $content if ref($content_ref) eq 'SCALAR';
		if (ref($content_ref) eq 'ARRAY') {
			$content =~ s/\r?\n$//;
			@$content_ref = map { chomp; $_ } split(/\r?\n/, $content, -1);
		}
	}
	return defined wantarray? $content: undef;
}

sub save_file ($$) {
	my $file_name = shift;
	print STDERR "save_file: $file_name\n"
		if $ENV{DEBUG} && ("$ENV{DEBUG}" & "\4") ne "\0";
	open(FILE, ">$file_name") or die "Can't save $file_name: $!\n";
	print FILE
		ref($_[0]) eq 'SCALAR'? ${$_[0]}:
		ref($_[0]) eq 'ARRAY'? map { m|$/$|? $_: "$_$/" } @{$_[0]}:
		$_[0];
	close(FILE) or die "Can't close $file_name in save: $!\n";
	return 1;
}

sub copy_dir ($$) {
	my $dir1 = shift;
	my $dir2 = shift;
	my $out = run_cmd("/bin/cp -PRp", $dir1, $dir2);
	warn $out if $out;
}

sub remove_dir (@) {
	my @dirs = grep { $_ } @_;
	return unless @dirs;
	my $out = run_cmd("/bin/rm -rf", @dirs);
	warn $out if $out;
}

sub setup_config_dir (;$@) {
	my $dir = shift;
	$dir ||= $ENV{ARCH_MAGIC_DIR};
	$dir ||= ($ENV{HOME} || "/tmp") . "/.arch-magic";

	foreach my $subdir ("", @_) {
		next unless defined $subdir;
		$dir .= "/$subdir" unless $subdir eq "";
		stat($dir);
		die "$dir exists, but it is not a writable directory\n"
			if -e _ && !(-d _ && -w _);
		unless (-e _) {
			print STDERR "making dir: $dir\n"
				if $ENV{DEBUG} && ("$ENV{DEBUG}" & "\2") ne "\0";
			mkdir($dir, 0777) or die "Can't mkdir $dir: $!\n";
		}
	}
	return $dir;
}

my %months = (
	Jan => 1, Feb => 2, Mar => 3, Apr => 4, May => 5, Jun => 6,
	Jul => 7, Aug => 8, Sep => 9, Oct => 10, Nov => 11, Dec => 12,
);
sub standardize_date ($) {
	my $date = shift;
	if ($date =~ /\w+ (\w+) +(\d+) +(\d+):(\d+):(\d+) (\w+) (\d+)/) {
		$date = sprintf("%04d-%02d-%02d %02d:%02d:%02d %s",
			$7, $months{$1} || 88, $2, $3, $4, $5, $6);
	}
	return $date;
}

# return (creator_name, creator_email, creator_username)
sub parse_creator_email ($) {
	my $creator = shift;
	my $email = '[e-mail]';
	my $username = "_none_";
	if ($creator =~ /^(.*?)\s*<((?:(.+?)@)?.*)>$/) {
		($creator, $email, $username) = ($1, $2, $3);
	}
	return ($creator, $email, $username);
}

sub adjacent_revision ($$) {
	my $full_revision = shift;
	my $offset = shift || die "adjacent_revision: no offset given\n";
	die "adjacent_revision: no working revision\n" unless $full_revision;

	$full_revision =~ /^(.*--.*?)(\w+)-(\d+)$/
		or die "Invalid revision ($full_revision)\n";
	my $prefix = $1;
	my $new_num = $3 + $offset;
	return undef if $new_num < 0;
	my $new_word = $2 =~ /^patch|base$/?
		$new_num? 'patch': 'base':
		$new_num? 'versionfix': 'version';
	return "$prefix$new_word-$new_num";
}

sub date2daysago ($) {
	my $date_str = shift;

	return -10000 unless $date_str =~ /^(\d{4})-(\d{2})-(\d{2}) (\d{2}):(\d{2}):(\d{2}) ([^\s]+)/;

	# timezone is not taken in account...
	require Time::Local;
	my $time = Time::Local::timegm($6, $5, $4, $3, $2 - 1, $1 - 1900);
	my $daysago = int((time - $time) / 60 / 60 / 24);

	return $daysago unless wantarray;
	return ($daysago, $time, $7);
}

sub date2age ($) {
	my $daysago = date2daysago($_[0]);
	return "bad-date" if $daysago <= -10000;

	my ($sign, $days) = $daysago =~ /^(-?)(.*)$/;
	my $str =
		$days ==   1? "1 day":
		$days <=  33? "$days days":
		$days <=  59? int($days / 7 + 0.5) . " weeks":
		$days <= 550? int($days / 30.42 + 0.5) . " months":
		int($days / 365.25 + 0.5) . " years";
	return "$sign$str";
}

# gets tla lines with undef meaning the delimiter for revisions;
# intended for parsing of "abrowse --desc" and "logs --cDs"
sub _parse_revision_descs ($$) {
	my $num_spaces = shift || die;
	my $revision_lines = shift || die;

	my $spaces = " " x $num_spaces;
	$spaces || die "Invalid number of spaces ($num_spaces)";

	my @revision_descs = ();
	while (@$revision_lines) {
		my ($line1, $line2) = splice @$revision_lines, 0, 2;
		my @summary_lines = ();
		push @summary_lines, shift @$revision_lines while defined $revision_lines->[0];
		shift @$revision_lines;  # throw away undef delimiter
		my $summary = join("\n", @summary_lines);
		$line2 =~ s/^$spaces//; $summary =~ s/^$spaces//mg;

		my ($name, $kind) = $line1 =~ /^(\S+)(?:\s+\((.*?)\))?/
			or die "Unexpected output of tla, subline 1:\n\t$line1\n";
		$kind = !$kind? "unknown": $kind =~ /tag/? "tag": $kind =~ /import/? "import": "cset";
		my ($date, $creator) = $line2 =~ /^(.+?)\s{6}(.*)/
			or die "Unexpected output of tla, subline 2:\n\t$line2\n";
		$date = standardize_date($date);
		my $age = date2age($date);

		my @version_part;
		push @version_part, 'version', $1 if $name =~ s/^(.*)--(.*)/$2/;

		my ($creator1, $email, $username) = parse_creator_email($creator);
		push @revision_descs, {
			name     => $name,
			summary  => $summary,
			creator  => $creator1,
			email    => $email,
			username => $username,
			date     => $date,
			age      => $age,
			kind     => $kind,
			@version_part,
		};
	}
	return \@revision_descs;
}

1;

__END__