From 416ab8a37f1b07dc9f6c0fb3ff1a8ff2036510b5 Mon Sep 17 00:00:00 2001 From: Sebastian Schmelzer Date: Thu, 2 Sep 2010 17:50:49 +0200 Subject: change dir structure --- src/bin/devel-tools/determineMinimumPackageSet.pl | 183 ++++++++++++++++ src/bin/devel-tools/extractTranslations.pl | 242 ++++++++++++++++++++++ src/bin/devel-tools/generateSettings.pl | 207 ++++++++++++++++++ src/bin/devel-tools/parseSusePatterns.pl | 163 +++++++++++++++ 4 files changed, 795 insertions(+) create mode 100755 src/bin/devel-tools/determineMinimumPackageSet.pl create mode 100755 src/bin/devel-tools/extractTranslations.pl create mode 100755 src/bin/devel-tools/generateSettings.pl create mode 100755 src/bin/devel-tools/parseSusePatterns.pl (limited to 'src/bin/devel-tools') diff --git a/src/bin/devel-tools/determineMinimumPackageSet.pl b/src/bin/devel-tools/determineMinimumPackageSet.pl new file mode 100755 index 00000000..52d13fc5 --- /dev/null +++ b/src/bin/devel-tools/determineMinimumPackageSet.pl @@ -0,0 +1,183 @@ +#! /usr/bin/perl +# ----------------------------------------------------------------------------- +# Copyright (c) 2006, 2007 - OpenSLX GmbH +# +# This program is free software distributed under the GPL version 2. +# See http://openslx.org/COPYING +# +# If you have any feedback please consult http://openslx.org/feedback and +# send your suggestions, praise, or complaints to feedback@openslx.org +# +# General information about OpenSLX can be found at http://openslx.org/ +# ----------------------------------------------------------------------------- +use strict; +use warnings; + +my $abstract = q[ +determineMinimumPackageSet.pl + This script is a tool for OpenSLX developers that allows to extract + the minimal package-set from all the installed rpm packages. + "Minimum" here means those packages only that are not + required by other installed packages (a.k.a. the leaves of the RPM + dependency graph). + This minimal set is useful to simplify the commandline for yum when + it is invoked to install a specific selection. +]; + +use Getopt::Long; +use Pod::Usage; + +my ( + $helpReq, + $verbose, + $versionReq, + + %pkgs, + @leafPkgs, +); + +my $rpmOutFile = "/tmp/minpkgset.rpmout"; +my $rpmErrFile = "/tmp/minpkgset.rpmerr"; + +GetOptions( + 'help|?' => \$helpReq, + 'verbose' => \$verbose, + 'version' => \$versionReq, +) or pod2usage(2); +pod2usage(-msg => $abstract, -verbose => 0, -exitval => 1) if $helpReq; +if ($versionReq) { + system('slxversion'); + exit 1; +} + +determineMinimumPackageSet(); + +print "THE MINIMUM PACKAGE LIST:\n"; +print(('-' x 40)."\n"); +print join("\n", sort @leafPkgs)."\n"; + +exit; + +sub slurpFile +{ + my $file = shift; + + my $fh; + open($fh, '<', $file) + or die _tr("could not open file '%s' for reading! (%s)", $file, $!); + local $/ = undef; + my $text = <$fh>; + close($fh); + return $text; +} + +sub rpmDie +{ + my $rpmCmd = shift; + + print "\n*** An error occurred when executing the following rpm-command:\n"; + print "\t$rpmCmd\n"; + my $err = slurpFile($rpmErrFile); + print "*** The error was:\n"; + print "\t$err\n"; + exit 5; +} + +sub callRpm +{ + my $rpmCmd = shift; + + my $res = system("$rpmCmd >$rpmOutFile 2>$rpmErrFile"); + exit 1 if ($res & 127); # child caught a signal + rpmDie($rpmCmd) if -s $rpmErrFile; + my $out = slurpFile($rpmOutFile); + return ($res, $out); +} + +sub handlePackage +{ + my $pkgName = shift; + + # if any other package requires it, the current package is not a leaf! + print "\tdirectly required..." if $verbose; + my ($rpmRes, $rpmOut) = callRpm(qq[rpm -q --whatrequires "$pkgName"]); + print $rpmRes ? "no\n" : "yes\n" if $verbose; + return 0 unless $rpmRes; + + print "\tany of its provides required..." if $verbose; + ($rpmRes, $rpmOut) = callRpm(qq[rpm -q --provides "$pkgName"]); + my $provides + = join ' ', + map { + my $rpm = $_; + $rpm =~ s[^\s*(.+?)\s*$][$1]; + qq["$rpm"]; + } + split "\n", $rpmOut; + ($rpmRes, $rpmOut) = callRpm(qq[rpm -q --whatrequires $provides]); + if ($rpmRes == 0) { + # ignore if rpm tells us that a provides is required by + # the package that provides it: + $rpmRes = 1; + while($rpmOut =~ m[^\s*(.+?)\s*]gm) { + if ($1 ne $pkgName) { + $rpmRes = 0; + last; + } + } + } + print $rpmRes ? "no\n" : "yes\n" if $verbose; + return 0 unless $rpmRes; + + print "!!! adding $pkgName\n" if $verbose; + push @leafPkgs, $pkgName; + return 1; +} + +sub determineMinimumPackageSet +{ + my ($rpmRes, $allPkgs) + = callRpm(qq[rpm -qa --queryformat "%{NAME}\n"]); + foreach my $p (sort split "\n", $allPkgs) { + print "$p...\n" if $verbose; + print "." unless $verbose; + handlePackage($p); + } + return; +} + +__END__ + +=head1 NAME + +determineMinimumPackageSet.pl - OpenSLX script to extract the minimum package +set from all the installed rpm packages. + +=head1 SYNOPSIS + +determineMinimumPackageSet.pl [options] + + Options: + --help brief help message + --verbose show files as they are being processed + --version show version + +=head1 OPTIONS + +=over 8 + +=item B<--help> + +Prints a brief help message and exits. + +=item B<--verbose> + +Prints information about each installed package as it is being processed. + +=item B<--version> + +Prints the version and exits. + +=back + +=cut \ No newline at end of file diff --git a/src/bin/devel-tools/extractTranslations.pl b/src/bin/devel-tools/extractTranslations.pl new file mode 100755 index 00000000..789a70ad --- /dev/null +++ b/src/bin/devel-tools/extractTranslations.pl @@ -0,0 +1,242 @@ +#! /usr/bin/perl +# ----------------------------------------------------------------------------- +# Copyright (c) 2006, 2007 - OpenSLX GmbH +# +# This program is free software distributed under the GPL version 2. +# See http://openslx.org/COPYING +# +# If you have any feedback please consult http://openslx.org/feedback and +# send your suggestions, praise, or complaints to feedback@openslx.org +# +# General information about OpenSLX can be found at http://openslx.org/ +# ----------------------------------------------------------------------------- +# extractTranslations.pl +# - OpenSLX-script to extract translatable strings from other scripts +# and modules. +# ----------------------------------------------------------------------------- +use strict; +use warnings; + +my $abstract = q[ +extractTranslations.pl + This script is a tool for OpenSLX developers that allows to extract + translatable strings from all OpenSLX perl-scripts and modules found + in and below a given path. + + Optionally, all the translatable strings that were found can automatically + be integrated into all existing translation modules. During this process, + any translations already existing in these modules will be preserved. +]; + +use Cwd; +use File::Find; +use Getopt::Long; +use Pod::Usage; + +use OpenSLX::Utils; + +my ( + $helpReq, + $show, + $update, + $verbose, + $versionReq, + + %translatableStrings, + $fileCount, +); + +GetOptions( + 'help|?' => \$helpReq, + 'update' => \$update, + 'show' => \$show, + 'verbose' => \$verbose, + 'version' => \$versionReq, +) or pod2usage(2); +pod2usage(-msg => $abstract, -verbose => 0, -exitval => 1) if $helpReq; +if ($versionReq) { + system('slxversion'); + exit 1; +} + +# chdir to the repository's root folder: +use FindBin; +my $path = "$FindBin::RealBin/../.."; +chdir($path) + or die "can't chdir to repository-root <$path> ($!)"; +print "searching in ".cwd()."\n"; + +find(\&ExtractTrStrings, '.'); + +my $trCount = scalar keys %translatableStrings; +print "Found $trCount translatable strings in $fileCount files.\n"; + +if ($show) { + foreach my $tr (sort {lc($a) cmp lc($b)} keys %translatableStrings) { + print "\tqq{$tr}\n\t\t=> qq{$tr}\n"; + } +} + +if ($update) { + find(\&UpdateTrModule, 'lib/OpenSLX/Translations'); +} + +exit; + +sub ExtractTrStrings +{ + $File::Find::prune = 1 if ($_ eq '.svn' + || $_ eq 'Translations' + || $_ eq 'devel-tools'); + return if -d; + my $text = slurpFile($_); + if ($File::Find::name !~ m[\.pm$] && $text !~ m[^#!.+/perl]im) { + # ignore anything other than perl-modules and -scripts + return; + } + print "$File::Find::name...\n"; + $fileCount++; + while($text =~ m[_tr\s*\(\s*(.+?)\s*\);]gos) { + # NOTE: that cheesy regex relies on the string ');' not being used + # inside of translatable strings... so SLX_DONT_DO_THAT! + # As an alternative, we could implement a real parser, but + # I'd like to postpone that until the current scheme proves + # simply not good enough. + my $tr = $1; + if (!($tr =~ m[^'([^']+)'\s*(,.+?)*\s*$]os + || $tr =~ m[^\"([^"]+)\"\s*(,.+?)*\s*$]os + || $tr =~ m{^qq?\[([^\]]+)\]\s*(,.+?)*\s*$}os)) { + die "$File::Find::name: could not parse _tr()-argument \n" + ."\t$tr\nPlease correct and retry.\n"; + } + $tr = $1; + if ($tr =~ m[(\$\w+)]) { + die "$File::Find::name: _tr()-argument\n\t$tr\n" + ."contains variable '$1'.\nPlease correct and retry.\n"; + } + $tr =~ s[\n][\\n]g; + $tr =~ s[\t][\\t]g; + $translatableStrings{$tr} = $tr; + print "\t$tr\n" if $verbose; + } +} + +sub UpdateTrModule +{ + $File::Find::prune = 1 if ($_ eq '.svn'); + return if -d || !/.pm$/; + print "updating $File::Find::name...\n"; + my $trModule = $_; + my $useKeyAsTranslation = ($trModule eq 'posix.pm'); + my $text = slurpFile($trModule); + if ($text !~ m[%translations\s*=\s*\(\s*(.+)\s*\);]os) { + print "\t*** No translations found - file will be skipped! ***\n"; + return; + } + my %translations; + # evaluate the hash read from file into %translations: + if (!eval "$&") { + print "\t*** translations can't be evaluated - file will be skipped! ***\n"; + return; + } + my $updatedTranslations = "%translations = (\n"; + my $keepCount = 0; + my $newCount = 0; + foreach my $tr (sort {lc($a) cmp lc($b)} keys %translatableStrings) { + if (!length($translations{$tr})) { + if ($useKeyAsTranslation) { + # POSIX language (English): use key as translation: + $updatedTranslations + .= "\tq{$tr}\n\t=>\n\tqq{$tr},\n\n"; + $newCount++; + } else { + # no translation available, we mark the key, such that a + # search for this key will fall back to the english message: + my $trMark = "NEW:$tr"; + if (exists $translations{$trMark}) { + # the marked string already exists, we keep the translation + # if any (usually, of course, there is none): + my $trValue = $translations{$trMark}; + $trValue =~ s[\n][\\n]g; + $trValue =~ s[\t][\\t]g; + $updatedTranslations + .= "\tq{$trMark}\n\t=>\n\tqq{$trValue},\n\n"; + $keepCount++; + } else { + $updatedTranslations + .= "\tq{$trMark}\n\t=>\n\tqq{},\n\n"; + $newCount++; + } + } + } else { + # use existing translation for key: + my $trValue = $translations{$tr}; + $trValue =~ s[\n][\\n]g; + $trValue =~ s[\t][\\t]g; + $updatedTranslations + .= "\tq{$tr}\n\t=>\n\tqq{$trValue},\n\n"; + $keepCount++; + } + } + my $delCount = scalar(keys %translations) - $keepCount; + $text =~ s[%translations\s*=\s*\(\s*(.+)\s*\);] + [$updatedTranslations);]os; + if ($newCount + $delCount) { + chomp $text; + spitFile($trModule, $text."\n"); + print "\tadded $newCount strings, kept $keepCount and removed $delCount.\n"; + } else { + print "\tnothing changed\n"; + } +} + +__END__ + +=head1 NAME + +extractTranslations.pl - OpenSLX-script to extract translatable strings from +all scripts and modules found in and below the given path. + +=head1 SYNOPSIS + +extractTranslations.pl [options] + + Options: + --help brief help message + --update update the OpenSLX locale modules + (in lib/OpenSLX/Translations) + --show show overview of all strings found + --verbose show for each file which strings are found + --version show version + +=head1 OPTIONS + +=over 8 + +=item B<--help> + +Prints a brief help message and exits. + +=item B<--show> + +Prints sorted list of all translatable strings that were found. + +=item B<--update> + +Integrates the found translatable strings into all OpenSLX locale modules found +under lib/OpenSLX/Translations. +Every module will be updated with the found strings, existing +translations will not be changed (unless the corresponding key doesn't exist +anymore, in which case they will be removed). + +=item B<--verbose> + +Prints information about what's going on during execution of the script. + +=item B<--version> + +Prints the version and exits. + +=back + +=cut \ No newline at end of file diff --git a/src/bin/devel-tools/generateSettings.pl b/src/bin/devel-tools/generateSettings.pl new file mode 100755 index 00000000..b0e1b447 --- /dev/null +++ b/src/bin/devel-tools/generateSettings.pl @@ -0,0 +1,207 @@ +#! /usr/bin/perl +# ----------------------------------------------------------------------------- +# Copyright (c) 2006 - 2009 - OpenSLX GmbH +# +# This program is free software distributed under the GPL version 2. +# See http://openslx.org/COPYING +# +# If you have any feedback please consult http://openslx.org/feedback and +# send your suggestions, praise, or complaints to feedback@openslx.org +# +# General information about OpenSLX can be found at http://openslx.org/ +# ----------------------------------------------------------------------------- +use strict; +use warnings; +use Data::Dumper; +my $abstract = q[ +determineMinimumPackageSet.pl + This script is a tool for OpenSLX developers that is meant to generate a + packageset for settings.default. It can be used to generate + bootstrap-packages for example. +]; + +use Getopt::Long; +use Pod::Usage; + +my ( + $helpReq, + $verbose, + $versionReq, + $inputfile, + $outputfile, + $url, + $errorfile, + + @Pkgs, + @files, + @GivenNames, + @filelisting, + @errors, +); + +$errorfile="/tmp/genSettings.err"; +GetOptions( + 'help|?' => \$helpReq, + 'verbose' => \$verbose, + 'version' => \$versionReq, + 'if=s' => \$inputfile, + 'of=s' => \$outputfile, + 'url=s' => \$url, +) or pod2usage(2); +pod2usage(-msg => $abstract, -verbose => 0, -exitval => 1) if $helpReq; +if ($versionReq) { + system('slxversion'); + exit 1; +} + +open(INPUTFILE,$inputfile) || die("Can't open input-file $inputfile!"); + while (my $zeile=){ + if ($zeile ne "") { + push (@GivenNames,$zeile); + } + } +close(INPUTFILE); + +print "getting filelisting:\n" if $verbose; +if (substr($url,0,3) eq "ftp") { + print "\trecognized mirror as ftp - $url\n" if $verbose; + @filelisting=_getPackageListingFtp($url); +} elsif (substr($url,0,4) eq "http") { + print "\trecognized mirror as http - $url\n" if $verbose; + @filelisting=_getPackageListingHttp($url); +} else { + die "Unable to get mirror type (ftp or http)"; +} +print "\tgot file listing from $url\n" if $verbose; +print "resolving names:\n" if $verbose; +foreach my $name (@GivenNames) { + $name=~ s/^[\s\t]+//; #removes whitespaces + $name=~ s/[\n\t\r]$//; #removes new lines + my @possiblepackages = grep(/^\Q$name\E*/i,@filelisting); + my $res; + if ($possiblepackages[0]) { + $res = $possiblepackages[0]; + } else { + push (@errors,$name); + } + print "\t$name->$res\n" if $verbose; + push (@Pkgs,$res) if $res; +} +open (OUTPUTFILE,">>$outputfile") || die("Can't open output-file $outputfile!"); +foreach my $package (@Pkgs) { + print OUTPUTFILE "$package\n"; +} +close (OUTPUTFILE); +open (ERRORFILE,">>$errorfile") || die("Can't open output-file $errorfile!"); + foreach my $error (@errors) { + print ERRORFILE "$error\n"; +} +close (ERRORFILE); +print "\n"; + +if ($verbose) { + print "THE PACKAGE LIST:\n"; + print(('=' x 40)."\n"); + print join("\n", sort @Pkgs)."\n"; +} + +exit; + + +sub _getPackageListingFtp { + my $url = shift; + use Net::FTP; + use URI; + require URI::_generic; + + my $urlObject = URI->new($url); + my $path = shift; + my $ftp = Net::FTP->new($urlObject->host( ), Timeout => 240) + or die _tr("Unable to connect to FTP-Server"); + $ftp->login("anonymous", "mailaddress@"); + $ftp->cwd($urlObject->path( )); + return $ftp->ls(); +} + +sub _getPackageListingHttp { + my $url = shift; + use URI; + use URI::http; + use URI::_foreign; + use HTTP::Request; + use LWP::UserAgent; + use LWP::Protocol::http; + + my @filelisting; + my $ua = LWP::UserAgent->new; + $ua->agent("Mozilla/5.0 (Windows; U; Windows NT 5.1; de; rv:1.8) Gecko/20051111 Firefox/1.5"); + my $req; + $req = HTTP::Request->new(GET => $url); + $req->header('Accept' => 'text/html'); + + # send request + my $res = $ua->request($req); + # check the outcome + if ($res->is_success) { + print "\tThe given URL is : $url\n" if $verbose; + @filelisting = ($res->decoded_content =~ m/status_line . "\n"); +} + + +__END__ + +=head1 NAME + +generateSettings.pl - OpenSLX script to extract full package names +from a given mirror. + +=head1 SYNOPSIS + +generateSettings.pl [options] + + Options: + --if inputfile + --of outputfile + --url url of the mirror + --help brief help message + --verbose show files as they are being processed + --version show version + +=head1 OPTIONS + +=over 8 + +=item B<--if> + +Select input file with package names in each line. + +=item B<--of> + +Select output file for complete package names to append. + +=item B<--url> + +Select a mirror directory for the desired distribution + +=item B<--help> + +Prints a brief help message and exits. + +=item B<--verbose> + +Prints information about each installed package as it is being processed. + +=item B<--version> + +Prints the version and exits. + +=back + +=cut diff --git a/src/bin/devel-tools/parseSusePatterns.pl b/src/bin/devel-tools/parseSusePatterns.pl new file mode 100755 index 00000000..a286cd71 --- /dev/null +++ b/src/bin/devel-tools/parseSusePatterns.pl @@ -0,0 +1,163 @@ +#! /usr/bin/perl +# ----------------------------------------------------------------------------- +# Copyright (c) 2006, 2007 - OpenSLX GmbH +# +# This program is free software distributed under the GPL version 2. +# See http://openslx.org/COPYING +# +# If you have any feedback please consult http://openslx.org/feedback and +# send your suggestions, praise, or complaints to feedback@openslx.org +# +# General information about OpenSLX can be found at http://openslx.org/ +# ----------------------------------------------------------------------------- +# parseSusePatterns.pl +# - OpenSLX script to extract a package list from a given list of +# SUSE-pattern-files (*.pat). +# ----------------------------------------------------------------------------- +use strict; +use warnings; + +my $abstract = q[ +parseSusePatterns.pl + This script is a tool for OpenSLX developers that allows to extract + package lists from a given set of SUSE pattern files. +]; + +use Getopt::Long; +use Pod::Usage; + +my ( + $helpReq, + $versionReq, + + %patternNames, + %packageNames, +); + +GetOptions( + 'help|?' => \$helpReq, + 'version' => \$versionReq, +) or pod2usage(2); +pod2usage(-msg => $abstract, -verbose => 0, -exitval => 1) if $helpReq; +if ($versionReq) { + system('slxversion'); + exit 1; +} + +if ($ARGV[0] !~ m[^(\w+)-(.+)$]) { + die "can't extract architecture from pattern file name '$ARGV[0]'"; +} +my $arch = $2; + +foreach my $patternFile (@ARGV) { + parsePatternFile($patternFile, 1); +} + +print join("\n", sort keys %packageNames)."\n"; + +exit; + +sub parsePatternFile +{ + my $patternFile = shift; + my $outmost = shift; + + my $patFH; + if (!open($patFH, '<', $patternFile)) { + return unless $outmost; + die "unable to open $patternFile"; + } + undef $/; + my $content = <$patFH>; + close($patFH); + $patternNames{$patternFile} = 1; + + if ($content =~ m[^\=Sum.de:\s*(.+?)\s*$]ms) { + print "+ $1\n"; + } + if ($content =~ m[^\+Sug:\s*?$(.+?)^\-Sug:\s*?$]ms) { + addSubPatterns($1); + } + if ($content =~ m[^\+Req:\s*?$(.+?)^\-Req:\s*?$]ms) { + addSubPatterns($1); + } + if ($content =~ m[^\+Rec:\s*?$(.+?)^\-Rec:\s*?$]ms) { + addSubPatterns($1); + } + if ($content =~ m[^\+Prq:\s*?$(.+?)^\-Prq:\s*?$]ms) { + addPkgNames($1); + } + if ($content =~ m[^\+Prc:\s*?$(.+?)^\-Prc:\s*?$]ms) { + addPkgNames($1); + } + return; +} + +sub addSubPatterns +{ + my $patternNames = shift; + + my @subPatterns + = grep { length($_) > 0 } + map { + my $pattern = $_; + $pattern =~ s[^\s*(.+?)\s*$][$1]; + $pattern; + } + split "\n", $patternNames; + + foreach my $subPattern (@subPatterns) { + my $subPatternFile = "$subPattern-$arch"; + if (!exists $patternNames{$subPatternFile}) { + parsePatternFile($subPatternFile); + } + } + return; +} + +sub addPkgNames +{ + my $pkgs = shift; + + my @pkgNames + = grep { length($_) > 0 } + map { + my $pkg = $_; + $pkg =~ s[^\s*(.+?)\s*$][$1]; + $pkg; + } + split "\n", $pkgs; + foreach my $pkgName (@pkgNames) { + $packageNames{$pkgName} = 1; + } + return; +} + +=head1 NAME + +parseSusePatterns.pl - OpenSLX script to extract a package list from +a given list of SUSE-pattern-files (*.pat). + +=head1 SYNOPSIS + +parseSusePatterns.pl [options] ... + + Options: + --help brief help message + --version show version + +=head1 OPTIONS + +=over 8 + +=item B<--help> + +Prints a brief help message and exits. + +=item B<--version> + +Prints the version and exits. + +=back + +=cut \ No newline at end of file -- cgit v1.2.3-55-g7522