258 lines
6.5 KiB
Perl
258 lines
6.5 KiB
Perl
package UpdateBerlios;
|
|
|
|
use LWP::UserAgent;
|
|
use HTTP::Request;
|
|
use HTTP::Request::Form;
|
|
use HTTP::Cookies;
|
|
use HTML::TreeBuilder;
|
|
use Data::Dumper;
|
|
use strict;
|
|
|
|
# Configuration.
|
|
my $LOGINACTION="https://developer.berlios.de/account/login.php";
|
|
my $EDITRELEASE="https://developer.berlios.de/project/admin/editreleases.php";
|
|
|
|
my %TYPE=
|
|
('deb' => '1000',
|
|
'rpm' => '2000',
|
|
'zip' => '3000',
|
|
'bz2' => '3001',
|
|
'gz' => '3002',
|
|
'exe' => '4000',
|
|
'srczip' => '5000',
|
|
'srcbz2' => '5001',
|
|
'srcgz' => '5002',
|
|
'srcrpm' => '5100',
|
|
'srcother' => '5900',
|
|
'jpg' => '8000',
|
|
'txt' => '8001',
|
|
'html' => '8002',
|
|
'pdf' => '8003',
|
|
'other' => '9999');
|
|
|
|
my %ARCH=
|
|
('x86' => '1000',
|
|
'ia64' => '6000',
|
|
'alpha' => '7000',
|
|
'any' => '8000',
|
|
'ppc' => '2000',
|
|
'mips' => '3000',
|
|
'sparc' => '4000',
|
|
'sparc64' => '5000',
|
|
'other' => '9999',
|
|
'x86_64' => '9000');
|
|
|
|
sub new
|
|
{
|
|
my ($class)=@_;
|
|
my $self=
|
|
{ projurl => undef };
|
|
bless $self, $class;
|
|
return $self;
|
|
}
|
|
|
|
sub connect
|
|
{
|
|
my ($self, $user, $passwd)=@_;
|
|
chomp $user;
|
|
chomp $passwd;
|
|
|
|
$self->{ua}=new LWP::UserAgent;
|
|
$self->{ua}->agent("Oolite-Updater/1.0");
|
|
$self->{ua}->cookie_jar( {} );
|
|
|
|
my $forms=$self->getForms($LOGINACTION);
|
|
my $login=new HTTP::Request::Form($forms->[2], $LOGINACTION);
|
|
|
|
$login->field('form_loginname', $user);
|
|
$login->field('form_pw', $passwd);
|
|
$login->field('stay_in_ssl', 1);
|
|
|
|
my $res=$self->{ua}->request($login->press('login'));
|
|
|
|
# test for session cookie to see if login worked
|
|
if($self->{ua}->cookie_jar->as_string =~ /session_hash/)
|
|
{
|
|
print("Logged into BerliOS as $user\n");
|
|
return 1;
|
|
}
|
|
print("Login failed");
|
|
exit(255);
|
|
}
|
|
|
|
sub deleteFiles
|
|
{
|
|
my ($self, $url)=@_;
|
|
|
|
# The general idea here is to keep hitting Delete until there
|
|
# are no more delete forms left (all files are gone).
|
|
while(1)
|
|
{
|
|
my $forms=$self->getForms($url);
|
|
|
|
# iterate through the list of forms to find one that lets
|
|
# us delete.
|
|
my $candidate=undef;
|
|
my $delfound=0;
|
|
foreach my $form (@$forms)
|
|
{
|
|
$candidate=new HTTP::Request::Form
|
|
($form, $EDITRELEASE);
|
|
if($candidate->field("step3") eq "Delete File")
|
|
{
|
|
$delfound=1;
|
|
last;
|
|
}
|
|
}
|
|
if(!$delfound)
|
|
{
|
|
# Nothing more
|
|
last;
|
|
}
|
|
|
|
# the html doesn't seem to parse properly so for deleting we have
|
|
# to do this by hand!!
|
|
my $reqstr="group_id=" . $candidate->field('group_id');
|
|
$reqstr.="&release_id=" . $candidate->field('release_id');
|
|
$reqstr.="&package_id=" . $candidate->field('package_id');
|
|
$reqstr.="&file_id=" . $candidate->field('file_id');
|
|
$reqstr.="&im_sure=1";
|
|
$reqstr.="&step3=Delete File";
|
|
my $req=HTTP::Request->new(POST => $url);
|
|
$req->content_type('application/x-www-form-urlencoded');
|
|
$req->content($reqstr);
|
|
|
|
my $res=$self->{ua}->request($req);
|
|
if($res->is_success)
|
|
{
|
|
print("Deleted file id " . $candidate->field('file_id') . "\n");
|
|
}
|
|
else
|
|
{
|
|
die("Delete failed!");
|
|
}
|
|
}
|
|
}
|
|
|
|
# call this as thing->addFiles("http://...", file1, file2, ...);
|
|
sub addFiles
|
|
{
|
|
my $self=shift;
|
|
my $url=shift;
|
|
|
|
my $forms=$self->getForms($url);
|
|
my $fileform=new HTTP::Request::Form($forms->[2], $EDITRELEASE);
|
|
if($fileform->field('step2') ne "1")
|
|
{
|
|
die("Unexpected value for step2: " . $fileform->field('step2'));
|
|
}
|
|
|
|
# the form module can't parse this form (probably because of the
|
|
# repeated field names) so we do it by hand.
|
|
my @params;
|
|
while(my $filename=shift())
|
|
{
|
|
push @params, "file_list[]=$filename";
|
|
}
|
|
my $reqstr=join("&", @params);
|
|
|
|
$reqstr.="&group_id=" . $fileform->field('group_id');
|
|
$reqstr.="&package_id=" . $fileform->field('package_id');
|
|
$reqstr.="&release_id=" . $fileform->field('release_id');
|
|
$reqstr.="&step2=1";
|
|
|
|
my $req=HTTP::Request->new(POST => $url);
|
|
$req->content_type('application/x-www-form-urlencoded');
|
|
$req->content($reqstr);
|
|
my $res=$self->{ua}->request($req);
|
|
if($res->is_success)
|
|
{
|
|
if(! grep /File(s) Added/, $res->content)
|
|
{
|
|
return undef;
|
|
}
|
|
}
|
|
else
|
|
{
|
|
die("Request failed");
|
|
}
|
|
return ($fileform->field('group_id'), $fileform->field('package_id'),
|
|
$fileform->field('release_id'));
|
|
}
|
|
|
|
sub setFileArchitectures
|
|
{
|
|
my ($self, $url, $arch, $type)=@_;
|
|
|
|
# make sure arch/type can be converted
|
|
my $arch=$ARCH{$arch};
|
|
my $type=$TYPE{$type};
|
|
|
|
if(!defined($arch) || !defined($type))
|
|
{
|
|
print("Arch/type not found (arch was '$arch', type was '$type')\n");
|
|
exit;
|
|
}
|
|
|
|
my $forms=$self->getForms($url);
|
|
my $candidate=undef;
|
|
my %fileIdList;
|
|
|
|
# all we're doing is getting a list of all file_ids and changing
|
|
# them en-masse.
|
|
foreach my $form (@$forms)
|
|
{
|
|
$candidate=new HTTP::Request::Form
|
|
($form, $EDITRELEASE);
|
|
if(length($candidate->field('file_id')) &&
|
|
$candidate->field('step3') eq "1")
|
|
{
|
|
$fileIdList{$candidate->field('file_id')}=
|
|
"group_id=" . $candidate->field('group_id') .
|
|
"&release_id=" . $candidate->field('release_id') .
|
|
"&package_id=" . $candidate->field('package_id') .
|
|
"&file_id=" . $candidate->field('file_id') .
|
|
"&step3=1&processor_id=$arch&type_id=$type" .
|
|
"&new_release_id=" . $candidate->field('release_id') .
|
|
"&release_time=" . `date +"%Y-%m-%d"`;
|
|
}
|
|
}
|
|
|
|
foreach my $fileId (keys %fileIdList)
|
|
{
|
|
print("Updating file_id $fileId...\n");
|
|
my $req=HTTP::Request->new(POST => $url);
|
|
$req->content_type('application/x-www-form-urlencoded');
|
|
$req->content($fileIdList{$fileId});
|
|
my $res=$self->{ua}->request($req);
|
|
if($res->is_success)
|
|
{
|
|
if(! grep /File Updated/, $res->content)
|
|
{
|
|
print("Warning: possibly did not update file_id $fileId\n");
|
|
}
|
|
}
|
|
else
|
|
{
|
|
die("Request failed");
|
|
}
|
|
}
|
|
}
|
|
|
|
sub getForms
|
|
{
|
|
my ($self, $url)=@_;
|
|
|
|
my $req=new HTTP::Request(GET => $url);
|
|
my $res=$self->{ua}->request($req);
|
|
my $tree=new HTML::TreeBuilder;
|
|
$tree->parse($res->content);
|
|
$tree->eof;
|
|
|
|
# enumerate forms
|
|
my @forms=$tree->find_by_tag_name('FORM')
|
|
or die("No forms found at $url");
|
|
return \@forms;
|
|
}
|
|
|