Update of /cvsroot/leaf/src/The_UnNamed_One/buildtool/buildtool/DownloadTypes
In directory
sc8-pr-cvs6.sourceforge.net:/tmp/cvs-serv15949/buildtool/buildtool/DownloadTypes
Added Files:
CvsExt.pm CvsPserver.pm File.pm Ftp.pm Http.pm ViewCVS.pm
Wget.pm
Log Message:
initial import
--- NEW FILE: File.pm ---
# $Id: File.pm,v 1.1 2008/03/01 16:24:19 hejl Exp $
package buildtool::DownloadTypes::File;
# "download type" that allows to copy a file locally
# sample buildtool.cfg:
#
#
#<Server local>
# Type = file
# serverpath = ../linux
#</Server>
#
#
#<File linux-2.4.20.tar.bz2>
# Server = local
# dlpath = .
#</File>
#
# if this is for the package "kerneltest" this means:
# the file $BT_ROOT/source/linux/linux-2.4.20.tar.bz2
# will be copied to
# the file $BT_ROOT/source/kerneltest/linux-2.4.20.tar.bz2
use strict;
use Carp;
use File::Spec;
use buildtool::Common::Object;
use vars qw(@ISA $VERSION);
@ISA = qw(buildtool::Common::Object);
sub new($$)
{
my ($type,
%params) = @_;
foreach my $name ("config", "serverpath", "filename") {
if (!(exists($params{$name}) && $params{$name})) {
confess ("no " . $name . " given");
}
}
my $self = $type->SUPER::new(\%{$params{'config'}}, %params);
$self->_initialize(%params);
return($self);
}
sub _initialize($$) {
my ($self, %params) = @_;
$self->debug("starting");
# $self->SUPER::_initialize(%params);
# use Data::Dumper;
# my $dumper = Data::Dumper->new([$self, \%params]);
# my $dumper = Data::Dumper->new([\%params]);
# $dumper->Indent(1);
# print STDERR $dumper->Dumpxs(), "\n";
$self->debug("buildtool::DownloadTyped::File _initialize called");
$self->{'DLPATH'} = ".";
$self->{'PATH'} = $params{'serverpath'};
$self->{'PATH'} .= "/" .$params{'dir'} if ($params{'dir'} and
$params{'dir'} ne "") ;
$self->{'FILENAME'} = $params{'filename'};
$self->{'SOURCEFILE'} = $self->stripSlashes(
File::Spec->catfile(
$self->{'PATH'},
$self->{'FILENAME'}));
$self->{'FULLPATH'} = $self->stripSlashes(
File::Spec->catfile(
$params{'dlroot'},
$self->{'DLPATH'},
$self->{'FILENAME'}));
}
sub download($) {
my ($self) = @_;
# first check if file exists, else set error and return
if (! -f $self->{'SOURCEFILE'}) {
my $msg = "file ". $self->{'SOURCEFILE'} . " does not exist";
$self->debug($msg);
$self->_setErrorMsg($msg);
return 0;
}
my $cp = ['cp', $self->{'SOURCEFILE'}, $self->{'FULLPATH'} ];
if (! $self->overwriteFileOk($self->{'FULLPATH'}) ) {
#$self->{'CONFIG'}->{'overwritefiles'} and -e $self->{'FULLPATH'}) {
# just log what we don't do
$self->logme("not overwriting file ". $self->{'FULLPATH'} ." as
requested");
} else {
$self->debug("calling cp with:" . join(" ", @{$cp}));
if ((system (@{$cp})>>8) != 0) {
my $msg= "cp failed: " . join(" ", @{$cp});
$self->debug($msg);
$self->_setErrorMsg($msg);
return 0;
}
}
# give back true return code
return 1;
}
1;
--- NEW FILE: Http.pm ---
# $Id: Http.pm,v 1.1 2008/03/01 16:24:20 hejl Exp $
package buildtool::DownloadTypes::Http;
use strict;
use Carp;
use File::Spec;
use buildtool::DownloadTypes::Wget;
use vars qw(@ISA $VERSION);
$VERSION = '0.3';
@ISA = qw(buildtool::DownloadTypes::Wget);
sub new($$)
{
my %params = (dir => "");
my $type;
($type, %params) = @_;
my $self = $type->SUPER::new(%params);
# initialization , not done by new();
$self->_initialize(%params);
return($self);
}
sub _initialize($$) {
my ($self, %params) = @_;
$self->debug("http::initialize called");
# first check the params
## $self->_checkParams(%params);
# use wget initialize:
$self->SUPER::_initialize(%params);
$self->{'PROTOCOL'} ='http://';
}
# the rest is identical to Wget
1;
--- NEW FILE: Ftp.pm ---
# $Id: Ftp.pm,v 1.1 2008/03/01 16:24:20 hejl Exp $
package buildtool::DownloadTypes::Ftp;
use strict;
use Carp;
use File::Spec;
use buildtool::DownloadTypes::Wget;
use vars qw(@ISA $VERSION);
@ISA = qw(buildtool::DownloadTypes::Wget);
$VERSION = '0.3';
sub new($$)
{
my %params = (dir => "");
my $type;
($type, %params) = @_;
my $self = $type->SUPER::new(%params);
# initialization , not done by new();
$self->_initialize(%params);
return($self);
}
sub _initialize($$) {
my ($self, %params) = @_;
$self->debug("ftp::initialize called");
# first check the params
$self->_checkParams(%params);
# use wget initialize:
$self->SUPER::_initialize(%params);
$self->{'PROTOCOL'} ='ftp://';
}
# the rest is identical to Wget
1;
--- NEW FILE: ViewCVS.pm ---
# $Header:
/cvsroot/leaf/src/The_UnNamed_One/buildtool/buildtool/DownloadTypes/ViewCVS.pm,v
1.1 2008/03/01 16:24:20 hejl Exp $
# cleaneup done
package buildtool::DownloadTypes::ViewCVS;
use strict;
use Carp;
use File::Spec;
use buildtool::DownloadTypes::Wget;
use vars qw(@ISA $VERSION);
$VERSION = '0.3';
@ISA = qw(buildtool::DownloadTypes::Wget);
sub new($$)
{
my %params = ( revision => "0.0.0.0",
dir => "");
my $type = "";
($type, %params) = @_;
my $self = $type->SUPER::new(%params);
# initialization , not done by new();
$self->_initialize(%params);
##
$self->{'REVISION'} = $params{'revision'};
return($self);
}
sub _initialize($$) {
my ($self, %params) = @_;
$self->debug("ViewCVS::initialize called");
# first check the params
$self->_checkParams(%params);
# use wget initialize:
$self->SUPER::_initialize(%params);
$self->{'WGET_CONTINUE'} = 0;
$self->{'USE_ATTIC'} = 0;
}
sub _checkParams ($$) {
my ($self, %params) = @_;
$self->SUPER::_checkParams(%params);
# check for revision addionaly
confess($params{'revision'} . " is not a valid revision") if
(!(exists($params{'revision'}) and ($params{'revision'} =~ /[0-9\.]+/) or
$params{'revision'} eq "HEAD")) ;
}
sub _getURL($;$) {
my ($self, $from_attic) = @_;
my $attic = '';
$attic = '/Attic' if ($self->{'USE_ATTIC'});
return $self->stripSlashes('http://' .
$self->{'SERVER'} .
'/*checkout*/' .
$self->{'SERVERPATH'} .
'/' . $self->{'DIR'} .
$attic .
'/' . $self->{'FILENAME'} .
'?rev=' . $self->{'REVISION'} .
'&content-type=application/octet-stream') ;
}
sub download($) {
my ($self) = @_;
my $useAttic = 0;
my $url;
my $log = $self->getLogfile();
while (1) {
# use download from wget...
if ($self->SUPER::download() != 1) {
# download failed,
# try the Attic version:
# changed for viewcvs >= 0.8
$self->{'USE_ATTIC'} = 1;
$self->debug("file was removed from cvs, trying it from attic");
}
my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
$atime,$mtime,$ctime,$blksize,$blocks) = stat($self->{'FULLPATH'});
if (!$size or $size==0) {
$self->die("wget failed", $self->{'FULLPATH'}.' could not be found');
}
# now we have downloaded something, check if this is an html page
# and if so, throw an error cause something has gone wrong...
my $fh = Symbol::gensym();
my $line;
open($fh, '< ' . $self->{'FULLPATH'});
$line = <$fh>;
close $fh;
if ($line and ($line =~ /^<!doctype html/)) {
# something went wrong, we only got an html page, that's
# not what we want i suppose
# maybe it was just removed, so search for a FILE REMOVED in the output:
if (!$useAttic && system("grep -q 'FILE REMOVED' " . $self->{'FULLPATH'})
>>8 == 0) {
#retry with Attic
$self->{'USE_ATTIC'} = 1;
$self->debug("file was removed from cvs, getting it from attic");
# remove file
unlink($self->{'FULLPATH'});
next;
} else {
$self->die("wget failed", $self->{'FULLPATH'}.' seems to be an viewcvs
error message and not the file we wanted to download');
}
}
# if we get here, this means everything went ok
last;
}
return 1;
}
1;
--- NEW FILE: CvsExt.pm ---
# $Id: CvsExt.pm,v 1.1 2008/03/01 16:24:19 hejl Exp $
package buildtool::DownloadTypes::CvsExt;
use buildtool::DownloadTypes::CvsPserver;
use vars qw(@ISA $VERSION);
$VERSION = '0.1';
@ISA = qw(buildtool::DownloadTypes::CvsPserver);
######################################################
# construct the cvsroot from username and ...
sub _mkCvsRoot ($) {
my $self = shift;
# check cvsroot
if (! ($self->{'CVSROOT'} =~ /^\/.*$/)) {
$self->{'CVSROOT'} = "/" . $self->{'CVSROOT'};
}
my $root = ":ext:" . $self->{'USERNAME'} . "\@". $self->{'SERVER'} . ":"
. $self->stripSlashes($self->{'CVSROOT'});
$self->debug("my root: " .$root);
return $root;
}
--- NEW FILE: Wget.pm ---
# $Id: Wget.pm,v 1.1 2008/03/01 16:24:20 hejl Exp $
package buildtool::DownloadTypes::Wget;
use strict;
use Carp;
use File::Spec;
use buildtool::Common::Object;
use vars qw(@ISA $VERSION);
@ISA = qw(buildtool::Common::Object);
sub new($$)
{
my ($type, %params) = @_;
# make new object ourself, don't call super!
my $self = $type->SUPER::new($params{'config'}, %params);
return($self);
}
sub _checkParams ($$) {
my ($self, %params) = @_;
# $self->dumpIt([EMAIL PROTECTED]);
## note: don't check for dir, this is optional and could be null
# check if we have everything in here we need
foreach my $name ("config", "dlroot", "server", "serverpath", "filename") {
confess ("no " . $name . " given") unless exists($params{$name}) &&
$params{$name};
}
return 1;
}
sub _getURL($) {
my ($self) = @_;
return $self->stripSlashes($self->{'PROTOCOL'} .
$self->{'SERVER'} .
"/" . $self->{'SERVERPATH'} .
'/' . $self->{'DIR'} .
'/' . $self->{'FILENAME'});
}
sub _initialize ($$) {
my ($self, %params) = @_;
$self->{'SERVER'} = $params{'server'};
$self->{'DLROOT'} = $params{'dlroot'};
$self->{'SERVERPATH'} = $params{'serverpath'};
$self->{'FILENAME'} = $params{'filename'};
$self->{'DIR'} = $params{'dir'};
$self->{'FULLPATH'} =
$self->stripSlashes(File::Spec->catfile($self->{'DLROOT'},
$self->{'FILENAME'}));
# should we use continue of dowloads (aka -c):
$self->{'WGET_CONTINUE'} = 1;
}
sub download($) {
my ($self) = @_;
# build url
my $url =$self->_getURL();
my $log = $self->getLogfile();
my @wget = ("wget", "-O", $self->{'FULLPATH'}, "-a", $log);
# check if we want the -c flag to be set
if ($self->{'WGET_CONTINUE'}) {
push @wget, "-c";
}
if ($self->{'CONFIG'}->{'wget_options'} and
($self->{'CONFIG'}->{'wget_options'} ne "")) {
foreach my $opt (split /\s+/, $self->{'CONFIG'}->{'wget_options'}) {
push @wget, $opt;
}
}
# add url
push @wget, $url;
# check if we should overwrite,
# note that wget itsels might fail, if we edit a file
# and it gets smaller, wget will try to download it again
if ( ! $self->overwriteFileOk($self->{'FULLPATH'})) {
# just log what we don't do
$self->logme("not overwriting file ". $self->{'FULLPATH'} ." as
requested");
} else {
# download and let wget handle this
$self->debug("calling wget with:" . join(" ", @wget));
if ((system (@wget)>>8) != 0) {
$self->_setErrorMsg("wget failed with: " . $! . " used:" .
join(" ", @wget));
return 0;
}
}
# if we get here, everything went ok
return 1;
}
1;
--- NEW FILE: CvsPserver.pm ---
# $Id: CvsPserver.pm,v 1.1 2008/03/01 16:24:19 hejl Exp $
package buildtool::DownloadTypes::CvsPserver;
sub BEGIN {
push @VCS::LibCVS::Authentication_Functions, \&myAuthentication;
}
# global hash for authentication...
$buildtool::DownloadTypes::CvsPserver::Auth_Values = {};
######################################################
# authentication function used by libcvs code
# will be called for authentication...
sub myAuthentication {
my ($scheme, $needed, $info) = @_;
return if ($scheme ne "pserver");
my %ret = ("scrambled_password" => "A");
# get the cvsroot from info
my $root = $info->{CVSRoot}->as_string();
# try to get our password from global hash
# workaround... i know...
if (exists $buildtool::DownloadTypes::CvsPserver::Auth_Values->{$root} and
$buildtool::DownloadTypes::CvsPserver::Auth_Values->{$root} ne "") {
%ret = ("scrambled_password" =>
$buildtool::DownloadTypes::CvsPserver::Auth_Values->{$root});
}
# use Data::Dumper;
# my $dumper = Data::Dumper->new([$info]);
# $dumper->Indent(1);
# print STDERR $dumper->Dumpxs(), "\n";
return \%ret;
}
use strict;
use Carp;
use File::Spec;
use buildtool::Common::Object;
use Data::Dumper;
use VCS::LibCVS;
use vars qw(@ISA $VERSION);
$VERSION = '0.1';
@ISA = qw(buildtool::Common::Object);
######################################################
sub new($$)
{
my ($type, %params) = @_;
# make new object ourself, don't call super!
my $self = $type->SUPER::new($params{'config'}, %params);
return($self);
}
######################################################
# check parameters given to constructor
sub _checkParams ($$) {
my ($self, %params) = @_;
## note: don't check for dir, this is optional and could be null
# check if we have everything in here we need
foreach my $name ("config", "dlroot", "server", "serverpath",
"filename", "cvsroot") {
confess($self->makeTextRed("Error in config:") . " in section
server:". $params{'server'}. " $name not defined\n\n") if (! $params{$name} or
($params{$name} eq ""));
}
return 1;
}
######################################################
# scramble password for pserver authentication
sub scramble($$) {
my $self = shift;
my @shifts= (0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14,
15,
16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30,
31,
114,120, 53, 79, 96,109, 72,108, 70, 64, 76, 67,116, 74, 68,
87,
111, 52, 75,119, 49, 34, 82, 81, 95, 65,112,
86,118,110,122,105,
41, 57, 83, 43, 46,102, 40, 89, 38,103, 45, 50, 42,123, 91,
35,
125, 55, 54, 66,124,126, 59, 47, 92, 71,115, 78, 88,107,106,
56,
36,121,117,104,101,100, 69, 73, 99, 63, 94, 93, 39, 37, 61,
48,
58,113, 32, 90, 44, 98, 60, 51, 33, 97, 62, 77, 84, 80,
85,223,
225,216,187,166,229,189,222,188,141,249,148,200,184,136,248,190,
199,170,181,204,138,232,218,183,255,234,220,247,213,203,226,193,
174,172,228,252,217,201,131,230,197,211,145,238,161,179,160,212,
207,221,254,173,202,146,224,151,140,196,205,130,135,133,143,246,
192,159,244,239,185,168,215,144,139,165,180,157,147,186,214,176,
227,231,219,169,175,156,206,198,129,164,150,210,154,177,134,127,
182,128,158,208,162,132,167,209,149,241,153,251,237,236,171,195,
243,233,253,240,194,250,191,155,142,137,245,235,163,242,178,152 );
my $string = shift;
my $retstring = "A";
#my $a = 0;
for (my $a = 0; $a < length($string) ; $a++) {
my $char = substr($string, $a, 1);
$retstring .= chr($shifts[ord($char)]);
}
$self->debug($retstring);
return $retstring;
}
######################################################
# internal initialize
sub _initialize ($$) {
my ($self, %params) = @_;
$self->_checkParams(%params);
$self->{'SERVER'} = $params{'server'};
$self->{'DLROOT'} = $params{'dlroot'};
$self->{'SERVERPATH'} = $params{'serverpath'};
$self->{'FILENAME'} = $params{'filename'};
$self->{'DIR'} = $params{'dir'};
$self->{'REVISION'} = $params{'revision'} || "HEAD";
$self->{'CVSROOT'} = $params{'cvsroot'};
if ($params{'username'} and $params{'username'} ne "") {
$self->{'USERNAME'} = $params{'username'} ;
} else {
$self->{'USERNAME'} = "anonymous";
}
$self->{'DEBUG'} = 1;
$self->debug(Dumper({%params}));
$self->debug("username:". $self->{'USERNAME'});
if ($params{'password'} and $params{'password'} ne "") {
$self->{'PASSWORD'} = $self->scramble($params{'password'});
} else {
$self->{'PASSWORD'} = $self->scramble("");
}
$self->{'FULLPATH'} =
$self->stripSlashes(File::Spec->catfile($self->{'DLROOT'},
$self->{'FILENAME'}));
# should we use continue of dowloads (aka -c):
$self->{'WGET_CONTINUE'} = 1;
# add cvsroot to global array
$buildtool::DownloadTypes::CvsPserver::Auth_Values->{$self->_mkCvsRoot} =
$self->{'PASSWORD'};
}
######################################################
# construct the cvsroot from username and ...
sub _mkCvsRoot ($) {
my $self = shift;
# check cvsroot
if (! ($self->{'CVSROOT'} =~ /^\/.*$/)) {
$self->{'CVSROOT'} = "/" . $self->{'CVSROOT'};
}
my $root = ":pserver:" . $self->{'USERNAME'} . "\@". $self->{'SERVER'} .
":" . $self->stripSlashes($self->{'CVSROOT'});
$self->debug("my root: " .$root);
return $root;
}
######################################################
# this function is called by global Download
sub download {
my $self = shift;
my $log = $self->getLogfile();
my $reproot = VCS::LibCVS::Datum::Root->new($self->_mkCvsRoot());
my $repo = VCS::LibCVS::Repository->new($reproot);
my $filename = "";
# check if OverwriteFiles is disabled, if so,
# do NOT overwrite
if ( ! $self->overwriteFileOk($self->{'FULLPATH'})) {
# just log what we don't do
$self->logme("not overwriting file ". $self->{'FULLPATH'} ."
as requested");
} else {
# add serverpath only if it is given
if ($self->{'SERVERPATH'} and $self->{'SERVERPATH'} ne "") {
$filename .= $self->{'SERVERPATH'} . "/";
}
if ($self->{'DIR'} and $self->{'DIR'} ne "") {
$filename .= $self->{'DIR'} . "/";
}
$filename .= $self->{'FILENAME'};
$self->stripSlashes($filename);
#remove leading / if there
$filename =~ s/^\///;
$self->debug("filename:" . $filename);
my $file = VCS::LibCVS::RepositoryFile->new($repo, $filename );
my $sticky;
if ($self->{'REVISION'} =~ /^[0-9.]+$/) {
$sticky = VCS::LibCVS::StickyRevision->new($repo,
$self->{'REVISION'});
} else {
$sticky = VCS::LibCVS::StickyTag->new($repo,
$self->{'REVISION'});
}
my $revision = $file->get_revision($sticky);
# get everything from server
my $contents = $revision->get_contents();
open TARGET, "> ". $self->{'FULLPATH'} or confess ("cannot open
file ". $self->{'FULLPATH'} . "for writing " );
# write buffer to file
print TARGET $contents->as_string();
close TARGET;
}
}
1;
-------------------------------------------------------------------------
This SF.net email is sponsored by: Microsoft
Defy all challenges. Microsoft(R) Visual Studio 2008.
http://clk.atdmt.com/MRT/go/vse0120000070mrt/direct/01/
_______________________________________________
leaf-cvs-commits mailing list
[email protected]
https://lists.sourceforge.net/lists/listinfo/leaf-cvs-commits
