package Module::Release::SourceForge;
=encoding utf8
=head1 NAME
Module::Release::SourceForge - Work with SourceForge with Module::Release
=head1 SYNOPSIS
All of this is horribly broken because Sourceforge changed everything.
This is the old code. If you want it, you have to fix it.
=cut
use strict;
use vars qw( $VERSION );
use warnings;
no warnings;
$VERSION = '2.06_04';
=head1 DESCRIPTION
=over 4
=item sourceforge_ftp_site
Return the hostname for SourceForge uploads.
=cut
sub sourceforge_ftp_site
{
$_[0]->{sourceforge_ftp_site};
}
=item should_upload_to_sourceforge
Returns true is the object thinks it should upload a distro to SourceForge.
=cut
sub should_upload_to_sourceforge
{
$_[0]->{cpan_user} && $_[0]->{cpan_pass}
}
=item sf_group_id
The Group ID of your SourceForge project. This is a numeric ID given to
the project usually, and you can see it in the URLs when you browse
the SourceForge files area.
=item sf_package_id
The Package ID of your SourceForge package. This is a numeric ID given to
a particular file release, and you can see it in the URLs when you browse
the SourceForge files area.
=item sf_release_match
This is a regular expression. Given the file release name that
C<Module::Release> picks (e.g. "Foo-Bar-1.15.tgz"), you can run a
substitution on it. The replacement string is in C<sf_release_replace>.
=item sf_release_replace
This is a regular expression. Given the file release name that
C<Module::Release> picks (e.g. "Foo-Bar-1.15.tgz"), you can run a
substitution on it. The regex portion is in C<sf_release_match>.
=item sf_type_id 5002
The distribution type (e.g. "gzipped source") of the package, by numeric
ID that you have to look up on your own from the SourceForge form. The
default is 5002 (".gz source").
=item sf_processor_id
The processor type (e.g. Intel Pentium) of the package, by numeric
ID that you have to look up on your own from the SourceForge form.
The default is 8000 ("Any").
=back
# SourceForge.net seems to know our path through the system
# Hit all the pages, collect the right cookies, etc
=over 4
=item sf_user( [ SF_USER ] )
Set or GET the SourceForge user name
=cut
sub sf_user
{
my $self = shift;
my $user = shift;
$self->config->set( 'sf_user', $user ) if defined $user;
return $self->config->sf_user;
}
=item sf_login
Authenticate with Sourceforge
=cut
sub sf_login
{
my $self = shift;
return unless $self->{sf};
$self->_print("Logging in to SourceForge.net... " );
my $cgi = CGI->new();
my $request = HTTP::Request->new( POST =>
'https://sourceforge.net/account/login.php' );
$self->{cookies}->add_cookie_header( $request );
$cgi->param( 'return_to', '' );
$cgi->param( 'form_loginname', $self->config->sf_user );
$cgi->param( 'form_pw', $self->{sf_pass} );
$cgi->param( 'persistent_login', 1 );
$cgi->param( 'login', 'Login' );
$request->content_type('application/x-www-form-urlencoded');
$request->content( $cgi->query_string );
$request->header( "Referer", "http://sourceforge.net/account/login.php" );
$self->_debug( $request->as_string, DASHES, "\n" );
my $response = $self->ua->request( $request );
$self->{cookies}->extract_cookies( $response );
$self->_debug( $response->headers_as_string, DASHES, "\n" );
REDIRECT: {
if( $response->code == 302 )
{
my $location = $response->header('Location');
$self->_debug( "Location is $location\n" );
my $request = HTTP::Request->new( POST => $location );
$request->content_type('application/x-www-form-urlencoded');
$request->content( $cgi->query_string );
$self->{cookies}->add_cookie_header( $request );
$self->_debug( $request->as_string, DASHES, "\n" );
$response = $self->ua->request( $request );
$self->_debug( $response->headers_as_string, DASHES, "\n" );
$self->{cookies}->extract_cookies( $response );
redo REDIRECT;
}
}
my $content = $response->content;
$content =~ s|.*<!-- begin SF.net content -->||s;
$content =~ s|Register New Project.*||s;
$self->_debug( $content );
my $sf_user = $self->config->sf_user;
if( $content =~ m/welcome.*$sf_user/i )
{
$self->_print( "Logged in!\n" );
return 1;
}
else
{
$self->_print( "Not logged in! Aborting\n" );
#return 0;
exit;
}
}
=item sf_qrs()
Visit the Quick Release System form
=cut
sub sf_qrs
{
my $self = shift;
return unless $self->{sf};
my $request = HTTP::Request->new( GET =>
'https://sourceforge.net/project/admin/qrs.php?package_id=&group_id=' .
$self->config->sf_group_id
);
$self->{cookies}->add_cookie_header( $request );
$self->_debug( $request->as_string, DASHES, "\n" );
my $response = $self->{ua}->request( $request );
$self->_debug( $response->headers_as_string, DASHES, "\n" );
$self->{cookies}->extract_cookies( $response );
}
=item sf_release()
Release the file to Sourceforge
=cut
sub sf_release
{
my $self = shift;
return unless $self->{sf};
my @time = localtime();
my $date = sprintf "%04d-%02d-%02d",
$time[5] + 1900, $time[4] + 1, $time[3];
$self->_print( "Connecting to SourceForge.net QRS... " );
my $cgi = CGI->new();
my $request = HTTP::Request->new(
POST => 'https://sourceforge.net/project/admin/qrs.php' );
$self->{cookies}->add_cookie_header( $request );
$cgi->param( 'MAX_FILE_SIZE', 1_000_000 );
$cgi->param( 'package_id', $self->config->sf_package_id );
$cgi->param( 'release_name', $self->{release} );
$cgi->param( 'release_date', $date );
$cgi->param( 'status_id', 1 );
$cgi->param( 'file_name', $self->remote_file );
$cgi->param( 'type_id', $self->config->sf_type_id || 5002 );
$cgi->param( 'processor_id', $self->config->sf_processor_id || 8000 );
$cgi->param( 'release_notes', $self->get_readme() );
$cgi->param( 'release_changes', $self->get_changes() );
$cgi->param( 'group_id', $self->config->sf_group_id );
$cgi->param( 'preformatted', 1 );
$cgi->param( 'submit', 'Release File' );
$request->content_type('application/x-www-form-urlencoded');
$request->content( $cgi->query_string );
$request->header( "Referer",
"https://sourceforge.net/project/admin/qrs.php?package_id=&group_id=" .
$self->config->sf_group_id
);
$self->_debug( $request->as_string, "\n", DASHES, "\n" );
my $response = $self->{ua}->request( $request );
$self->_debug( $response->headers_as_string, "\n", DASHES, "\n" );
my $content = $response->content;
$content =~ s|.*Database Admin.*?<H3><FONT.*?>\s*||s;
$content =~ s|\s*</FONT></H3>.*||s;
$self->_print( "$content\n" ) if $self->debug;
$self->_print( "File Released\n" );
}
=back
=head1 TO DO
* What happened to my Changes munging?
=head1 CREDITS
Ken Williams turned my initial release(1) script into the present
module form.
Andy Lester handled the maintenance while I was on my Big Camping
Trip. He applied patches from many authors.
Andreas KE<ouml>nig suggested changes to make it work better with PAUSE.
Chris Nandor helped with figuring out the broken SourceForge stuff.
=head1 SOURCE AVAILABILITY
This source is in Github:
https://github.com/briandfoy/module-release
=head1 AUTHOR
brian d foy, C<< <bdfoy@cpan.org> >>
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2002-2013 brian d foy. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
1;
__END__