#!/usr/bin/perl

#- Copyright (C) 2000 MandrakeSoft (fpons@mandrakesoft.com)
#-
#- 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, 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.

#- this program is based upon old urpmi.addmedia

#use strict qw(subs vars refs);
use urpm;

sub main {
    my ($name, $url, $with, $relative_hdlist, %options);
    #- parse /etc/urpmi/mirror.config if present, or use default mandrake mirror.
    my $mirrors = 'http://www.linux-mandrake.com/mirrorsfull.list';
    if (-e "/etc/urpmi/mirror.config") {
	local (*F, $_);
	open F, "/etc/urpmi/mirror.config";
	while (<F>) {
	    chomp; s/#.*$//; s/^\s*//; s/\s*$//;
	    /^url\s*=\s*(.*)/ and $mirrors = $1;
	}
	close F;
    }
# Translator: The URI types strings 'file:', 'ftp:', 'http:',
# Translator: and 'removable:' must not be translated!
# Translator: neither the ``with''.
# Translator: only what is between <brakets> can be translated.
    my $usage = N("usage: urpmi.addmedia [options] <name> <url> [with <relative_path>]
where <url> is one of
       file://<path>
       ftp://<login>:<password>@<host>/<path> with <relative filename of hdlist>
       ftp://<host>/<path> with <relative filename of hdlist>
       http://<host>/<path> with <relative filename of hdlist>
       removable://<path>

and [options] are from
") . N("  --help         - print this help message.
") . N("  --wget         - use wget to retrieve distant files.
") . N("  --curl         - use curl to retrieve distant files.
") . N("  --limit-rate   - limit the download speed.
") . N("  --proxy        - use specified HTTP proxy, the port number is assumed
                   to be 1080 by default (format is <proxyhost[:port]>).
") . N("  --proxy-user   - specify user and password to use for proxy
                   authentication (format is <user:password>).
") . N("  --update       - create an update medium.
") . N("  --probe-synthesis - try to find and use synthesis file.
") . N("  --probe-hdlist - try to find and use hdlist file.
") . N("  --no-probe     - do not try to find any synthesis or
                   hdlist file.
") . N("  --distrib      - automatically create all media from an installation
                   medium.
") . N("  --distrib-XXX  - automatically create a medium for XXX part of a
                   distribution, XXX may be main, contrib, updates or
                   anything else that has been configured ;-)
") . N("  --from         - use specified url for list of mirrors, the default is
                   %s
", $mirrors) . N("  --version      - use specified distribution version, the default is taken
                   from the version of the distribution told by the
                   installed mandrake-release package.
") . N("  --arch         - use specified architecture, the default is arch of
                   mandrake-release package installed.
") . N("  --virtual      - create virtual media wich are always up-to-date,
                   only file:// protocol is allowed.
") . N("  -c             - clean headers cache directory.
") . N("  -f             - force generation of hdlist files.
");

    $options{force} = 0;
    $options{noclean} = 1;
    $options{probe_with} = 'synthesis'; #- no the default is to probe synthesis file.
    my $urpm = new urpm;
    while ($_ = shift @_) {
	/^--?c/ and $options{noclean} = 0, next;
	/^--?h/ and next;
	/^--?f/ and ++$options{force}, next;
	/^--wget/ and $urpm->{sync} = sub { my $options = shift @_;
					    if (ref $options) { $options->{prefer} = 'wget' }
					    else { $options = { dir => $options, prefer => 'wget' } }
					    urpm::sync_webfetch($options, @_) }, next;
	/^--curl/ and $urpm->{sync} = \&urpm::sync_webfetch, next;
	/^--limit-rate$/ and do { $options{limit_rate} = shift @_; next };
	/^--proxy$/ and do {
	    my ($proxy, $port) = ($_ = shift @_) =~ m,^(?:http://)?([^:]+(:\d+)?)/*$, or
		die N("bad proxy declaration on command line\n");
	    $proxy .= ":1080" unless $port;
	    $urpm->{proxy}{http_proxy} = $proxy;
	    next;
	};
	/^--proxy-user$/ and do {
	    ($_ = shift @_) =~ /(.+):(.+)/, or
		die N("bad proxy declaration on command line\n");
	    $urpm->{proxy}{user} = $1;
	    $urpm->{proxy}{pwd} = $2;
	    next;
	};
	/^--probe-synthesis/ and $options{probe_with} = 'synthesis', next;
	/^--probe-hdlist/ and $options{probe_with} = 'hdlist', next;
	/^--no-probe/ and $options{probe_with} = undef, next;
	/^--distrib$/ and $options{distrib} = undef, next;
	/^--distrib-(.*)$/ and $options{distrib} = $1, next;
	/^--from$/ and $options{mirrors_url} = shift @_, next;
	/^--version$/ and $options{version} = shift @_, next;
	/^--arch$/ and $options{arch} = shift @_, next;
	/^--update$/ and $options{update} = 1, next;
	/^--virtual$/ and $options{virtual} = 1, next;
	/^-/ and die $usage . N("\nunknown options '%s'\n", $_);
	($name, $url, $with, $relative_hdlist) = ($_, @_);
	last;
    }
    #- allow not to give name immediately.
    $options{distrib} or $url or ($url, $name) = ($name, '');
    my ($type) = $url =~ m,^([^:]*)://, or $options{distrib} or die $usage;

    $urpm->read_config;
    exists $options{limit_rate} or $options{limit_rate} = $urpm->{options}{'limit-rate'};

    if (exists $options{distrib}) {
	if (defined $options{distrib}) {
	    $name or die $usage;
	    #- extended distribution support, code is directly inlined here.
	    #- -h always set, updates should allow setting update flag.
	    $options{distrib} eq 'updates' and $options{update} = 1;
	    #- official site by default.
	    $options{from} ||= $mirrors;
	    #- get default value unless already provided.
	    unless ($options{version} && $options{arch}) {
		my $db = URPM::DB::open;
		$db->traverse_tag('name', [ qw(mandrake-release basesystem) ], sub {
				      my ($pkg) = @_;
				      $pkg->release =~ /0\./ and $options{version} ||= 'cooker';
				      $options{version} ||= $pkg->version;
				      $pkg->arch ne 'noarch' and $options{arch} ||= $pkg->arch;
				  });
	    }
	    #- sanity checks...
	    $options{distrib} eq 'updates' && $options{version} eq 'cooker' and
	      die N("cannot add updates of a cooker distribution\n");
	    #- get mirrors list file in urpmi cache.
	    my ($basename) = $options{from} =~ /^.*\/([^\/]+)\/*$/;
	    unlink "$urpm->{cachedir}/partial/$basename";
	    eval {
		$urpm->{log}(N("retrieving mirrors at %s ...", $options{from}));
		$urpm->{sync}({ dir => "$urpm->{cachedir}/partial", quiet => 1, proxy => $urpm->{proxy} }, $options{from});
		$urpm->{log}(N("...retrieving done"));
	    };
	    $@ and $urpm->{log}(N("...retrieving failed: %s", $@));
	    #- examine its contents and create all requested media, url is now a simple regex.
	    my $heading = quotemeta($options{distrib});
	    my $qarch = quotemeta($options{arch});
	    local *F;
	    open F, "$urpm->{cachedir}/partial/$basename";
	    while (<F>) {
		chomp; s/#.*$//; s/^\s*//; s/\s*$//;
		my ($v, $a, $l, $burl, $relative_hdlist);
		if (($v, $a, $l, $burl, $relative_hdlist) = /^$heading:([^:]*):([^:]*):([^:]*):(\S*)(?:\s+with\s+(.*))?$/) {
		    $v eq '*' || $v eq $options{version} or next;
		    $a eq '*' || $a eq $options{arch} or next;
		} elsif (($a, $burl) = /^$heading([^:]*):(\S*)$/) {
		    $a eq $options{arch} or next;
		    $options{distrib} eq 'updates' and $burl = "$burl/$options{version}/RPMS";
		    $options{distrib} eq 'contrib' and $burl .= "2";
		} elsif (($a, $burl) = /^cooker([^:]*):(\S*)$/) {
		    #- specific case for old style mirrors file description (of Mandrake).
		    $options{version} eq 'cooker' && $options{distrib} eq 'contrib' or next;
		    $a eq $options{arch} or next;
		    $burl .= "2";
		} else {
		    # it could a blank line (from a commentary) or source description.
		    next;
		}
		#- sort according to url or location if possible.
		!$url || $l && $l =~ /$url/i || $burl =~ /$url/i or next;
		$urpm->add_medium($name, $burl, $relative_hdlist,
				  virtual => $options{virtual}, update => $options{update}, index_name => 0);
	    }
	    close F;
	} else {
	    $with || $relative_hdlist and die N("%s\nno need to give <relative path of hdlist> with --distrib", $usage);

	    $urpm->add_distrib_media($name, $url, virtual => $options{virtual}, update => $options{update});
	}
	$urpm->update_media(%options, callback => \&urpm::sync_logger);

	if (my @unsynced_media = grep { $_->{modified} } @{$urpm->{media}}) {
	    print STDERR join("\n", map { N("unable to update medium \"%s\"\n", $_->{name}) } @unsynced_media);

	    #- remove quietly the failing media.
	    $urpm->{log} = sub {};
	    $urpm->remove_selected_media;
	    $urpm->update_media(%options, callback => \&urpm::sync_logger);
	}
    } else {
	$name or die $usage;

	if ($with eq "with") {
	    $relative_hdlist or die N("%s\n<relative path of hdlist> missing\n", $usage);
	} elsif ($type =~ /ftp|http|rsync|ssh/) {
	    $options{probe_with} || $with eq "with" or die N("%s\n`with' missing for network media\n", $usage);
	}

	$urpm->add_medium($name, $url, $relative_hdlist, virtual => $options{virtual}, update => $options{update});
	$urpm->update_media(%options, callback => \&urpm::sync_logger);

	#- check creation of media (during update has been successfull)
	my ($medium) = grep { $_->{name} eq $name } @{$urpm->{media}};
	$medium or die N("unable to create medium \"%s\"\n", $name);
	if ($medium->{modified}) {
	    print STDERR N("unable to update medium \"%s\"\n", $name);
	    #- remove quietly the failing media.
	    $urpm->{log} = sub {};
	    $urpm->remove_selected_media;
	    $urpm->update_media(%options, callback => \&urpm::sync_logger);
	}
    }

    #- try to umount removable device which may have been mounted.
    $urpm->try_umounting_removables;
}

main(@ARGV);