Update of /cvsroot/leaf/src/The_UnNamed_One/buildtool/buildtool/Common
In directory
sc8-pr-cvs6.sourceforge.net:/tmp/cvs-serv15949/buildtool/buildtool/Common
Added Files:
FileTrace.pm InstalledFile.pm Object.pm
Log Message:
initial import
--- NEW FILE: FileTrace.pm ---
# $Id: FileTrace.pm,v 1.1 2008/03/01 16:24:17 hejl Exp $
#
package buildtool::Common::FileTrace;
use buildtool::Common::Object;
use File::Find;
use vars qw(@ISA);
@ISA = qw(buildtool::Common::Object);
sub _initialize {
my $self = shift;
$buildtool::Common::FileTrace::time = time();
@buildtool::Common::FileTrace::dirlist = ();
@buildtool::Common::FileTrace::filelist = ();
my %params = @_;
$self->{'startList'} = $self->{'CONFIG'}->{'tracepath'};
$self->SUPER::_initialize();
$self->{'part'} = $params{'part'};
$self->debug("Filetrace starting for part ". $self->{'part'});
# add every dir to our list at startup:
foreach my $name (@{$self->{'startList'}}) {
$name = $self->absoluteFilename($name);
find(\&buildtool::Common::FileTrace::mkDirList, ($name));
}
}
sub mkDirList {
my $filename = $File::Find::name;
if (-d $filename) {
push @buildtool::Common::FileTrace::dirlist, $filename;
}
}
sub matches {
my $searchfor = shift;
my @files = @_;
foreach my $file (@files) {
if ($file eq $searchfor) {
return 1;
}
}
return 0;
}
# create the file list
sub getFileList {
my $self = shift;
foreach my $name (@{$self->{'startList'}}) {
$buildtool::Common::FileTrace::dirName =
$self->absoluteFilename($name);
find(\&buildtool::Common::FileTrace::wanted, ($name));
}
}
sub wanted {
my $dirname = $File::Find::name;
my @fileinfo = stat($dirname);
if ($fileinfo[10] and $fileinfo[10] >= $time) {
if (-d $dirname) {
if (! &matches($dirname,
@buildtool::Common::FileTrace::dirlist)) {
push @buildtool::Common::FileTrace::filelist,
$dirname;
}
} else {
push @filelist, $dirname;
}
}
}
sub writeToFile {
my $self = shift;
my $file =
$self->absoluteFilename($self->{'CONFIG'}->{'buildtracedir'}) ."/".
$self->{'part'}. ".list";
$self->debug("opening $file for writing");
open WRITEFILE, ">$file" or die("unable to open file $file for
writing");
foreach my $file (@buildtool::Common::FileTrace::filelist) {
print WRITEFILE $file . "\n";
}
close WRITEFILE
}
1;
--- NEW FILE: Object.pm ---
# $Id: Object.pm,v 1.1 2008/03/01 16:24:18 hejl Exp $
package buildtool::Common::Object;
use strict;
use Carp;
use File::Spec;
use File::Path;
use vars qw($VERSION);
$VERSION = '0.5';
######################################################################
# constructor routine
#
sub new($$)
{
my ($type, $p_h_config, %rest) = @_;
my $self;
confess("Config is not a valid hash, is a ". ref($p_h_config)) if
(ref($p_h_config) ne "HASH") ;
$self= {
'CONFIG' => $p_h_config,
};
bless($self, $type);
$self->dumpIt(\%rest);
# if (scalar(keys(%rest)) > 0) {
# call init function if we have something to init
$self->_initialize(%rest);
# }
return($self);
}
######################################################################
# init function
#
sub _initialize() {
my $self = shift;
# empty function,
# fill if needed
######################################### default init #############
# set debug value of Class (for debugging output)
$self->{'DEBUG'} = $self->{'CONFIG'}->{'debugtoconsole'}
||$self->{'CONFIG'}->{'debugtologfile'} ;
######################################### default init END##########
}
######################################################################
# strip double slashes in paths
#
sub stripSlashes($$) {
my ($self,$str) = @_;
# remove all double slashes, unless they're part of the protocol
section of an url
$str =~ s,(?<!tp:)//,/,g;
return ($str);
}
######################################################################
# get logfilename
#
sub getLogfile($) {
my ($self) = @_;
return $self->absoluteFilename($self->{'CONFIG'}->{'logfile'});
}
######################################################################
# convert relative to absolute path
#
sub absoluteFilename($$) {
my ($self, $path) = @_;
$path = $self->stripSlashes($path);
if (!File::Spec->file_name_is_absolute($path)) {
$path =
File::Spec->catfile($self->{'CONFIG'}->{'root_dir'},$path);
}
# if the file is still not an absolute filename, try adding the root dir
if (!File::Spec->file_name_is_absolute($path)) {
$path = File::Spec->catfile(File::Spec->rootdir(),$path);
}
return $path;
}
######################################################################
# a debug routine for later purposes...
#
sub debug {
my $self = shift;
# no strict 'refs';
my $caller = (caller(1))[3];
if ( $self->{'CONFIG'}->{'debugtoconsole'} && $self->{'DEBUG'}) {
print "$caller:";
print join("",@_) . "\n" ;
}
if ($self->{'CONFIG'}->{'debugtologfile'} && $self->{'DEBUG'}) {
my $fh = Symbol::gensym();
open($fh, '>> ' . $self->getLogfile());
print $fh "$caller:";
print $fh join("",@_) . "\n" ;
close $fh;
}
}
######################################################################
# print something to the logfile
#
sub logme {
my $self = shift;
if ($self->{'CONFIG'}->{'debugtologfile'}) {
my $fh = Symbol::gensym();
open($fh, '>> ' . $self->getLogfile()) or die "cannot open
logfile" . $self->getLogfile();
print $fh join("",@_) . "\n" ;
close $fh;
}
}
####################################################
# just gives the text back in red
sub make_text_red($$) {
my ($self,$text) = @_;
# not very smart...but looks nice...
return "\e[1;31m$text\e[0;39m";
}
####################################################
# just gives the text back in red
sub makeTextRed($$) {
my ($self,$text) = @_;
# not very smart...but looks nice...
return "\e[1;31m$text\e[0;39m";
}
####################################################
# just gives the text back in yellow
sub make_text_yellow($$) {
my ($self,$text) = @_;
# not very smart...but looks nice...
return "\e[1;33m$text\e[0;39m";
}
####################################################
# just gives the test back in green
sub make_text_green($$) {
my ($self,$text) = @_;
# not very smart...but looks nice...
return "\e[1;32m$text\e[0;39m";
}
####################################################
# print a colored o.k.
sub printOk($) {
my ($self) = @_;
# just print a colored o.k.
print $self->make_text_green("[0.K.]");
}
sub print_ok($) {
my ($self) = @_;
$self->printOk();
}
####################################################
# print a colored failed
sub print_failed($) {
my ($self) = @_;
# just print a colored failed
print $self->make_text_red("[FAILED]");
}
#############################################################################
# strip all unneaded double slashes from an url,
# but leave the starting :// alone...
sub strip_slashes {
my $self = shift;
my $string = shift || "";
$string =~ s,//,/,g ;
# put in the *tp:// back again:
$string =~ s,^([a-zA-Z]+tp:)/(.*)$,$1//$2,;
return $string;
}
######################################################################
# check if file exists and size is > 0
#
sub fileExists {
my ($self, $filename) = @_;
confess "no filename given " if (!$filename or $filename eq "");
if ((-e $filename) and (-s $filename > 0)) {
return 1;
}
# else
return 0;
}
#################################################
# returns the position of the given item in array
sub getArrayPosition {
my $self = shift;
my $item = shift || "";
my @arr = @_;
# $self->debug("starting, item=$item");
my $a = 0;
for ($a = 0; $a < scalar(@arr); $a++) {
if ($arr[$a] eq $item) {
return $a;
}
}
# else return -1
return -1;
}
#######################################################################################
# delete the entry $del from the list completly
sub delFromArray ($$$) {
my $self = shift;
my $del = shift;
my @list = @_;
my $pos;
$self->debug("starting");
$pos = $self->getArrayPosition($del, @list);
# $self->debug("pos:$pos");
while (($pos = $self->getArrayPosition($del, @list)) >= 0) {
$self->debug("splicing $del at $pos ");
splice @list, $pos, 1;
}
return @list;
}
######################################################################
# searches if entry is in given list
sub isInList {
my ($self, $searchfor, @list) = @_;
foreach my $item (@list) {
if ($searchfor eq $item) {
return 1;
}
}
# else
return 0;
}
######################################################################
# checks if the given file exists and is > 0 and if overwriteFiles
# is set in the config
sub overwriteFileOk {
my ($self, $filename) = @_;
confess "no filename given " if (!$filename or $filename eq "");
if ((! $self->{'CONFIG'}->{'OverwriteFiles'} ) and
$self->fileExists($filename)) {
# don't overwrite the file !
$self->debug("should not overwrite $filename as OverwriteFiles is not set
in config");
return 0;
}
# else
return 1;
}
######################################################################
# just print everything for now.
sub print ($$) {
print join(" ",$@);
}
######################################################################
# get the internal error message from an object
sub getErrorMsg ($) {
my $self = shift;
return $self->{'ERRORMSG'} if ($self->{'ERRORMSG'});
# else
return "";
}
######################################################################
# set the internal error message from an object
sub _setErrorMsg ($) {
my ($self,$msg) = @_;
$self->{'ERRORMSG'} = $msg;
return 1;
}
######################################################################
# dump everything we have to the debug channel
# just a dirty hack...
sub dumpIt {
my $self = shift;
my $ref = shift || ();
my $count = shift || 0;
use Data::Dumper;
my $dumper = Data::Dumper->new([ref]);
$dumper->Indent(1);
$self->debug($dumper->Dumpxs() . "\n");
}
sub protectSlashes {
my ($self, $string) = @_;
$string =~ s/\//\\\//g;
return $string;
}
sub die {
my ($self, $prefix, $msg) = @_;
my $pmsg = "";
# start with an \n to empty the stdout buffer
print "\n";
if ($msg eq "") {
$msg = $prefix;
$prefix = "";
}
if ($prefix ne "") {
$pmsg = $self->makeTextRed($prefix . ": ") ;
$pmsg .= $msg;
} else {
$pmsg = $self->makeTextRed($msg) ;
}
$pmsg .= "\nyou might find useful information in log/buildtoollog\n\n";
die($pmsg);
}
1;
--- NEW FILE: InstalledFile.pm ---
# $Id: InstalledFile.pm,v 1.1 2008/03/01 16:24:17 hejl Exp $
# This file is should be used whenever you need the installedFile Stuff
#
package buildtool::Common::InstalledFile;
use buildtool::Common::Object;
use Config::General 2.15;
use Carp;
use strict;
use vars qw(@ISA);
@ISA = qw(buildtool::Common::Object);
######################################################################
# init function
#
sub _initialize() {
my $self = shift;
my $listfile = $self->absoluteFilename($self->{'CONFIG'}{installedfile});
my %installed = ();
$self->SUPER::_initialize();
# read in the file if it exists
if ( -e $listfile) {
%installed = Config::General::ParseConfig($listfile);
$self->debug("reading in installedfile $listfile");
} else {
$self->debug("starting with empty installedfile $listfile");
}
$self->{'INSTALLED'} = \%installed;
# what type we have
$self->{'TYPES'} = [ "source", "build"];
$self->{'FILENAME'} = $listfile;
}
##########################################################
# gets a list back for the given type, returns an array
sub getEntries() {
my $self = shift ;
my $type = shift || die "no type given";
$self->debug("starting");
# make sure the type is valid!
$self->checkType($type);
my %list = %{$self->{'INSTALLED'}};
if (exists $list{$type}) {
if (ref($list{$type}) eq "ARRAY") {
return @{$list{$type}};
} else {
return ($list{$type});
}
} else {
$self->debug("type $type does not exist in values");
}
return ;
}
##########################################################
# check if Type is valid
sub checkType() {
my $self = shift;
my $type = shift || die "no type to check given";
if ($self->isInList($type, @{$self->{'TYPES'}})) {
return 1;
}
# else
$self->debug("unknown type:$type list contains:" .
join(",",@{$self->{'TYPES'}}));
confess "unknown type $type";
}
##########################################################
# search in the installed package list for actual package
sub searchInstalled4Pkg {
my $self = shift;
my $type = shift || die "no type given";
my $entry = shift || die "no entry given";
$self->debug("starting");
# make sure the type is valid!
$self->checkType($type);
my %list = %{$self->{'INSTALLED'}};
if (exists $list{$type}) {
my @typelist = ();
if (ref($list{$type}) eq "ARRAY") {
@typelist = @{$list{$type}};
} else {
@typelist = ($list{$type})
}
if ($self->isInList($entry, @typelist)) {
# already in list
$self->debug("entry $entry found in $type list ");
return 1;
}
}
# failed, return 0;
$self->debug("entry $entry not in $type list");
return 0;
}
######### !!!!!!!!!!!!!!!
sub deleteEntry {
my $self = shift;
my $type = shift || die "no type given";
my $entry = shift || die "no entry given";
my $length;
# make sure the type is valid!
$self->checkType($type);
my %list = %{$self->{'INSTALLED'}};
my $off = -1;
#make path to file
$self->debug("starting, entry=$entry, type=$type");
# show a message:
print "deleting $entry type $type from installed list ";
# now search for entry
# check if entry is already in type...
if ($self->searchInstalled4Pkg($type, $entry)) {
# look if we have an array or just one entry:
if (ref($list{$type}) eq "ARRAY") {
# yes, we are an array, splice it off.
# get the position:
$off = $self->getArrayPosition($entry,@{$list{$type}});
# now cut it from array
if ($off >=0) {
$self->debug("splicing element $off from list");
splice(@{$list{$type}}, $off, 1);
} else {
$self->logme("off not greater 0, should not happen");
$self->print_failed();
print "\n";
return 0;
}
} else {
# not an array, but is in list, so must be a single entry
# just one entry, delete it:
delete $list{$type};
}
#################### end of searchInstalled4Pkg
} else {
# we have not found the entry we should delete...
# search if force is enabled:
$self->debug("type $type not in list");
if (!$self->{'CONFIG'}->{'force'}) {
# force is not enabled!
print "$entry is not installed ";
$self->print_failed();
print "\n";
return 0;
}
}
$self->print_ok();
print "\n";
#put back to myself:
$self->{'INSTALLED'} = \%list;
# do not automatically save it.
return 1;
}
##########################################################
# this here writes the list of installed packages/sources
# back to the disc
sub writeToFile {
my $self = shift;
$self->debug("starting");
my %list = %{$self->{'INSTALLED'}};
## now save it back
$self->debug("saving installedfile");
Config::General::SaveConfig($self->{'FILENAME'}, \%list);
return 1;
}
##########################################################
# adds one entry to the list
#
sub addEntry () {
my $self = shift;
my %list = %{$self->{'INSTALLED'}};
my $type = shift || die "no type given";
my $entry = shift || die "no entry given";
# make sure the type is valid!
$self->checkType($type);
# check if entry is already in type...
if ($self->searchInstalled4Pkg($type, $entry)) {
$self->debug("entry $entry is already in list $type, not adding");
return 1;
}
# else
# check what type we need to add:
# if the given type exists and is not
# an array, convert it to an array
if (exists $list{$type}) {
if (ref($list{$type}) eq "ARRAY") {
push @{$list{$type}}, $entry;
$self->debug("pushing $entry on list");
} elsif ($list{$type}) {
my $oldvalue = $list{$type};
$list{$type} = [$oldvalue, $entry];
$self->debug("pushing $entry and oldvalue on list");
} else {
die "entry $type in list is neither an ARRAY nor just a
value, something is really wrong here";
}
} else {
# new value
$self->debug("adding new single entry $entry to $type");
$list{$type} = $entry;
}
# put back the list:
%{$self->{'INSTALLED'}} = %list;
return 1;
}
###############################################################################
#
sub _getSourceDir () {
my $self = shift;
my $pkg = shift || confess("no pkg given");
# if ($pkg eq "") {
# return;
# }
return $self->absoluteFilename($self->{'CONFIG'}{'source_dir'}."/".$pkg);
}
###############################################################################
# show a list of installed packages/sources
sub showList ($) {
my $self = shift;
my @sources = $self->getEntries("source");
my @pkgs = $self->getEntries("source");
print "\nsourced sources or packages : \n";
print "-----------------------------------------------\n";
print "Nothing sourced yet\n\n" if (scalar(@sources) == 0);
foreach my $source (@sources) {
print $source . "\n";
}
print "\nbuild sources or packages : \n";
print "-----------------------------------------------\n";
print "Nothing build yet\n\n" if (scalar(@sources) == 0);
foreach my $pkg (@pkgs) {
print $pkg . "\n";
}
}
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
