view release on metacpan or  search on metacpan

Checkout.pm  view on Meta::CPAN

=head2 dest()

Set and/or get the destination directory. The directory need not be created ahead of time.

=head2 list_methods()

Return a hash with method names as keys, detection patterns and retrieval commands.
The values in this hash are aliases to the internal values. You can change them to e.g. 
add a -q flag if you find a command to be too noisy.

=head2 describe()

Returns a verbal description of the matching rules.

=head2 add_method(name, qr{url-match-pattern}, cmd_fmt_string, "Some descriptive text") 

Multiple commands can be specified for each name. Commands should be written in bourne shell 
syntax, with the following named sprintf templates: %(user)s, %(pass)s, %(url)s, %(dest)s.
Commands that contain %(user)s and/or %(pass)s are ignored, if username and/or password 
credentials are not given. Example:

  add_method('git', qr{^(git://.*|\.git/?)$}, "git clone --depth 1 %(url)s");

The destination directory is the current working directory while the command runs.
The templates are expanded using String::ShellQuote and Text::Sprintf::Named.

If an array-ref of patterns is specified instead of a pattern, the patterns
should be ordered by decreasing reliability. Methods are tested breadth-first.

If a subroutine reference is specified as third parameter, it is called with the URL and the 
return value of find_method(), and is expected to return a command or an array of commands.

=head2 method('*')

Limit the method by name. The default '*' means no limitation. An array of
method names can be specified, which denotes a first match choice.
This is helpful for URLs that do not match anything specific. 
This is harmless, as it still allows other methods if the URL matches there.

=cut

sub new
{
  my $self = shift;
  my $class = ref($self) || $self;
  my %obj = (ref $_[0] eq 'HASH') ? %{$_[0]} : @_;

  $obj{_methods} = 
  [
    { name => 'obs', pat => [qr{^(obs://|https://api\.(opensuse\.org|suse\.de)/(public/)?source/)}],
      osc => ['osc'], co => ['co', '--current-dir', '--expand-link'], 
      desc => "OpenSUSE Build Service(obs): URLs starting with obs://, https://api.opensuse.org/, https://api.suse.de are handled by 'osc checkout'. Path components /public and /source are stripped, the remaining path components are Project, Package,...

      cmd => sub { my ($url, $m) = @_;
        my $api = $1 if $url =~ s{^\w+://([^/]+)/+}{};	
	$url =~ s{^(public/+)?sources?/+}{};
	my $rev = $1 if $url =~ s{[\?&]rev=(\w+)}{};
	$url =~ s{\?.*}{};
	$url =~ s{:/}{:}g;
	my @pp = split m{/+}, $url;

	my @cmd = (@{$m->{osc}}, '-A', "https://$api", @{$m->{co}});
	push @cmd, '-r', $rev if defined $rev;
	## -S aka --server-side-source-service-files, what an ugly name!
	return [ shell_quote(@cmd, '-S', @pp), shell_quote(@cmd, @pp)];
      },
      fake_home => { '.oscrc' => q{
[general]
apiurl = https://$api

[https://$api]
user = %(user)s
pass = %(pass)s
keyring=0
} } },

    { name => 'git', pat => [qr{(^git://|\.git/?$)}], 
      desc => "git: URLs starting with git:// or ending in .git are handled by 'git clone'",
      cmd => ["git clone --depth 1 %(url)s"] },

    { name => 'svn', pat => [qr{^svn://}, qr{[/@]svn(root)?[\./].*/(trunk|branches)/}, qr{[/@]svn(root)?[\./]}], 
      desc => "Subversion(svn): URLs starting with git:// or containing /svn. followed by /trunk/ or /branches/ or containing /svn/ followed by /trunk/ or /branches/ are handled by 'svn checkout'. Second Prio: URLs containing only /svn. or /svn/",
      cmd => ["svn --no-auth-cache --non-interactive --trust-server-cert co -q --force %(url)s",
              "svn --no-auth-cache --non-interactive --trust-server-cert --username %(user)s --password %(pass)s co -q --force %(url)s" ] },

    { name => 'http', pat => [undef, undef, qr{^https?://}], 
      desc => "WWW(http): URLs starting with http:// or https:// are handled as third priority with 'wget -m', this third priority is a fallback, if no first or second priority commands match",
      cmd => ["wget -m -np -nd -nH --no-check-certificate -e robots=off %(url)s"] },
  ];

  $obj{_sel} = ['*'];

  return bless \%obj, $class;
}

sub dest
{
  my ($self, $dir) = @_;
  $self->{dest} = $dir if defined $dir;
  $self->{dest} = File::Temp::tempdir( "co_XXXXXX", TMPDIR => 1) 
    unless $self->{dest};
  return $self->{dest};
}

sub auth
{
  my ($self, $user, $pass) = @_;
  $self->{user} = $user if defined $user;
  $self->{pass} = $pass if defined $pass;
  return ($self->{user}, $self->{pass});
}

sub list_methods
{
  return $_[0]->{_methods};
}

sub describe
{
  my @d = map { $_->{desc} } @{$_[0]->{_methods}};