The London Perl and Raku Workshop takes place on 26th Oct 2024. If your company depends on Perl, please consider sponsoring and/or attending.
# vim: ts=4 sw=4

=head1 NAME

URI::virtual - virtual URI, refers to a list of prefixes.

=cut
package URI::virtual;

=head1 VERSION

Version 0.02

=cut
our $VERSION = '0.02';
=pod

package URI::virtual;

=head1 REQUIRES

URI::http, Carp

=cut
use warnings;
use URI::http;
our(@ISA) = qw(URI::http);


=head1 SYNOPSIS

 #
use lib "$ENV{PWD}/lib";
use URI;
use Data::Dumper;
my @uris = (
	URI->new("virtual://CPAN/authors/"),
	map { URI->new("virtual://CPAN/modules/")->resolve() } 1 .. 5,
);
for ( @uris ) {
	print ref, " => ", $_, "\n";
};
__DATA__
#my config
CPAN 	ftp://mirror.hiwaay.net/CPAN/ 
CPAN	ftp://csociety-ftp.ecn.purdue.edu/pub/CPAN
CPAN	ftp://cpan.mirrors.redwire.net/pub/CPAN/
#include /usr/portage/profiles/thirdpartymirrors
#my results
URI::virtual => virtual://CPAN/authors/
URI::ftp => ftp://cpan.mirrors.redwire.net/pub/CPAN///modules/
URI::ftp => ftp://cpan.mirrors.redwire.net/pub/CPAN///modules/
URI::ftp => ftp://csociety-ftp.ecn.purdue.edu/pub/CPAN//modules/
URI::ftp => ftp://csociety-ftp.ecn.purdue.edu/pub/CPAN//modules/
URI::ftp => ftp://cpan.mirrors.redwire.net/pub/CPAN///modules/

=cut

#private
use strict;
my @defaults = qw( ~/.lwp_virt );
my %lists;

sub fail {
	require "Carp";
	goto &Carp::confess;
};
=function lists
accepts a list of files, and uses the contents of those files as
the the package's lookup table.
=cut
sub lists {
	%lists = ();
	@defaults = @_;
	load_lists();
};
=function load_lists

load_lists accepts a list of filenames, and adds their contents to the
lookup table.

=cut
sub load_lists(@) {
	## discard self if called as method.  What would Sigmond say?
	my $self = shift if ref $_[0];
	local (@_,$_) = map { split } ( @_, @defaults );
	while ( @_ ) {
		$_ = shift;
		s/^~/$ENV{HOME}/;
		my $MAP;
		unless (open($MAP,$_)){
			warn("open:$_:$!\n");
			next;
		};
		while(<$MAP>){
			my ( $name, @urls ) = split;
			next unless defined($name);
			if ( $name eq "#include" ) {
				push(@_, @urls);
			} else {
				my $list = \$lists{$name};
				$$list=[] unless $$list;
				push(@{$$list},grep s{/*$}{}, @urls);
			};
		}
		close($MAP) or warn "error reading";
	};
};
=function resolve
returns a randomly selected concrete uri for a given URI::virtual object.  
=cut
sub resolve() {
	my $self = shift;
	die "I demand a paternity test!" unless $self->isa("URI::virtual");
	$self->load_lists();
	die "invalid scheme" unless $self->scheme eq 'virtual';
	my $name = $self->host();
	die "invalid host" unless defined $name;
	my $list = $lists{$name};
	die "no list for $name" unless  ( $list );
	my $mirr = $list->[int(rand(@{$list}))];
	unless ( defined $mirr ) {
		die "no urls for $name";
	};
	return URI->new( $mirr . $self->path() )->canonical();
};
1;