File Coverage

blib/lib/urpm/cfg.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package urpm::cfg;


use strict;
use warnings;
use urpm::util qw(any cat_ partition output_safe quotespace unquotespace);
use urpm::msg 'N';

=head1 NAME

urpm::cfg - routines to handle the urpmi configuration files

=head1 SYNOPSIS

=head1 DESCRIPTION

=over

=item load_config($file)

Reads an urpmi configuration file and returns its contents in a hash ref :

    {
	media => [
         {
            name => 'medium name 1',
	    url => 'http://...',
	    option => 'value',
	    ...
	 },
        ],
	global => {
	    # global options go here
	},
    }

Returns undef() in case of parsing error (and sets C<$urpm::cfg::err> to the
appropriate error message.)

=item dump_config($file, $config)

Does the opposite: write the configuration file, from the same data structure.
Returns 1 on success, 0 on failure.

=cut

#- implementations of the substitutions. arch and release are mdk-specific.
#- XXX this is fragile code, it's an heuristic that depends on the format of
#- /etc/release

my ($arch, $release);
sub _init_arch_release () {
    if (!$arch && !$release) {
	my $l = cat_('/etc/release') or return undef;
	($release, $arch) = $l =~ /release (\d+\.?\d?).*for (\w+)/;
	$release = 'cauldron' if $l =~ /cauldron/i;
    }
    1;
}

sub get_arch () { _init_arch_release(); $arch }

sub get_release () { _init_arch_release(); $release }

sub get_host () {
    my $h = cat_('/proc/sys/kernel/hostname') || $ENV{HOSTNAME} || `/bin/hostname`;
    chomp $h;
    $h;
}

our $err;

sub _syntax_error () { $err = N("syntax error in config file at line %s", $.) }

sub substitute_back {
    my ($new, $old) = @_;
    return $new if !defined($old);
    return $old if expand_line($old) eq $new;
    return $new;
}

my %substitutions;
sub expand_line {
    my ($line) = @_;
    unless (scalar keys %substitutions) {
	%substitutions = (
	    HOST => get_host(),
	    ARCH => get_arch(),
	    RELEASE => get_release(),
	);
    }
    foreach my $sub (keys %substitutions) {
	$line =~ s/\$$sub\b/$substitutions{$sub}/g;
    }
    return $line;
}

my $no_para_option_regexp = 'update|ignore|synthesis|noreconfigure|no-recommends|no-suggests|no-media-info|static|virtual|disable-certificate-check';

sub load_config_raw {
    my ($file, $b_norewrite) = @_;
    my @blocks;
    my $block;
    $err = '';
    -r $file or do {
	$err = N("unable to read config file [%s]", $file);
	return;
    };
    foreach (cat_($file)) {
	chomp;
	next if /^\s*#/; #- comments
	s/^\s+//; s/\s+$//;
	$_ = expand_line($_) unless $b_norewrite;
	if ($_ eq '}') { #-{
	    if (!defined $block) {
		_syntax_error();
		return;
	    }
	    push @blocks, $block;
	    undef $block;
	} elsif (defined $block && /{$/) { #-}
	    _syntax_error();
	    return;
	} elsif ($_ eq '{') {
	    #-} Entering a global block
	    $block = { name => '' };
	} elsif (/^(.*?[^\\])\s+(?:(.*?[^\\])\s+)?{$/) {
	    #- medium definition
	    my ($name, $url) = (unquotespace($1), unquotespace($2));
	    if (any { $_->{name} eq $name } @blocks) {
		#- hmm, somebody fudged urpmi.cfg by hand.
		$err = N("medium `%s' is defined twice, aborting", $name);
		return;
	    }
	    $block = { name => $name, $url ? (url => $url) : @{[]} };
	} elsif (/^(hdlist
	  |list
	  |with_hdlist
	  |with_synthesis
	  |with-dir
          |mirrorlist
	  |media_info_dir
	  |removable
	  |md5sum
	  |limit-rate
	  |nb-of-new-unrequested-pkgs-between-auto-select-orphans-check
	  |xml-info
	  |excludepath
	  |split-(?:level|length)
	  |priority-upgrade
	  |prohibit-remove
	  |downloader
	  |retry
	  |default-media
	  |download-all
	  |tune-rpm
	  |(?:curl|rsync|wget|prozilla|aria2)-options
	  )\s*:\s*['"]?(.*?)['"]?$/x) {
	    #- config values
	    $block->{$1} = $2;
	} elsif (/^key[-_]ids\s*:\s*['"]?(.*?)['"]?$/) {
	    $block->{'key-ids'} = $1;
	} elsif (/^(hdlist|synthesis)$/) {
	    # ignored, kept for compatibility
	} elsif (/^($no_para_option_regexp)$/) {
	    my $opt = $1;
	    if ($opt =~ s/no-suggests/no-recommends/) { # COMPAT
	        warn "WARNING: --no-suggests is deprecated. Use --no-recommends instead\n" if s/no-suggests/no-recommends/; # COMPAT
	    }
	    #- positive flags
	    $block->{$opt} = 1;
	} elsif (my ($no, $k, $v) =
          /^(no-)?(
	    verify-rpm
	    |norebuild
	    |fuzzy
	    |allow-(?:force|nodeps)
	    |(?:pre|post)-clean
	    |excludedocs
	    |compress
	    |keep
	    |ignoresize
	    |auto
	    |strict-arch
	    |nopubkey
	    |resume)(?:\s*:\s*(.*))?$/x
	) {
	    #- boolean options
	    my $yes = $no ? 0 : 1;
	    $no = $yes ? 0 : 1;
	    $v = '' unless defined $v;
	    $block->{$k} = $v =~ /^(yes|on|1|)$/i ? $yes : $no;
	} elsif ($_ eq 'modified') {
	    #- obsolete
	} else {
	    warn "unknown line '$_'\n" if $_;
	}
    }
    \@blocks;
}

sub load_config {
    my ($file) = @_;

    my $blocks = load_config_raw($file);
    my ($media, $global) = partition { $_->{name} } @$blocks;
    ($global) = @$global;
    delete $global->{name};

    { global => $global || {}, media => $media };
}

sub dump_config {
    my ($file, $config) = @_;

    my %global = (name => '', %{$config->{global}});

    dump_config_raw($file, [ %global ? \%global : @{[]}, @{$config->{media}} ]);
}

sub dump_config_raw {
    my ($file, $blocks) = @_;

    my $old_blocks = load_config_raw($file, 1);
    my $substitute_back = sub {
	my ($m, $field) = @_;
	my ($prev_block) = grep { $_->{name} eq $m->{name} } @$old_blocks;
	substitute_back($m->{$field}, $prev_block && $prev_block->{$field});
    };

    my @lines;
    foreach my $m (@$blocks) {
	my @l = map {
	    if (/^($no_para_option_regexp)$/) {
		$_;
	    } elsif ($_ ne 'priority') {
		"$_: " . $substitute_back->($m, $_);
	    }
	} sort grep { $_ && $_ ne 'url' && $_ ne 'name' } keys %$m;

        my $name_url = $m->{name} ?
	  join(' ', map { quotespace($_) } $m->{name}, $substitute_back->($m, 'url')) . ' ' : '';

	push @lines, join("\n", $name_url . '{', (map { "  $_" } @l), "}\n");
    }

    output_safe($file, join("\n", @lines)) or do {
	$err = N("unable to write config file [%s]", $file);
	return 0;
    };

    1;
}

1;


=back

=head1 COPYRIGHT

Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 MandrakeSoft SA

Copyright (C) 2005-2010 Mandriva SA

=cut