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 +++++++++ src/bin/slxldd | 128 ++++++++ src/bin/slxsettings | 381 ++++++++++++++++++++++ 6 files changed, 1304 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 create mode 100755 src/bin/slxldd create mode 100755 src/bin/slxsettings (limited to 'src/bin') 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 diff --git a/src/bin/slxldd b/src/bin/slxldd new file mode 100755 index 00000000..16d07b9c --- /dev/null +++ b/src/bin/slxldd @@ -0,0 +1,128 @@ +#! /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/ +# ----------------------------------------------------------------------------- +# slxldd +# - OpenSLX-rewrite of ldd that works on multiple architectures. +# ----------------------------------------------------------------------------- +use strict; +use warnings; + +my $abstract = q[ +slxldd + This script reimplements ldd in a way that should work for all + binary formats supported by the binutils installed on the host system. + + An example: if you have a folder containing an x86_64 system, you can + invoke this script on a x86_32-host in order to determine all the libraries + required by a binary of the x86_64 target system. +]; + +# add the lib-folder to perl's search path for modules: +use FindBin; +use lib "$FindBin::RealBin/../lib"; + +use File::Glob ':globally'; +use Getopt::Long; +use Pod::Usage; + +use OpenSLX::Basics; +use OpenSLX::LibScanner; + +my %option = ( + rootPath => '/', +); +GetOptions( + 'help|?' => \$option{helpReq}, + 'man' => \$option{manReq}, + 'root-path=s' => \$option{rootPath}, + 'verbose' => \$option{verbose}, + 'version' => \$option{versionReq}, + ) + or pod2usage(2); +pod2usage(-msg => $abstract, -verbose => 0, -exitval => 1) if $option{helpReq}; +pod2usage(-verbose => 2) if $option{manReq}; +if ($option{versionReq}) { + system('slxversion'); + exit 1; +} + +openslxInit(); + +if (!$option{rootPath}) { + print STDERR _tr("You need to specify the root-path!\n"); + pod2usage(2); +} + +$option{rootPath} =~ s[/+$][]; +# remove trailing slashes + +if (!@ARGV) { + print STDERR _tr("You need to specify at least one file!\n"); + pod2usage(2); +} + +my $libScanner = OpenSLX::LibScanner->new({ + 'root-path' => $option{rootPath}, + 'verbose' => $option{verbose}, +}); + +my @libs = $libScanner->determineRequiredLibs(@ARGV); +print join("\n", @libs), "\n"; + +=head1 NAME + +slxldd - OpenSLX-script to determine the libraries required by any given +binary file. + +=head1 SYNOPSIS + +slxldd [options] file [...more files] + + Options: + --help brief help message + --man show full documentation + --root-path= path to the root folder for library search + --verbose show what's going on during execution + --version show version + +=head1 OPTIONS + +=over 8 + +=item B<--help> + +Prints a brief help message and exits. + +=item B<--man> + +Prints the manual page and exits. + +=item B<--root-path=> + +Sets the root folder that is used when searching for libraries. In order to +collect the loader-settings, etc/ld.so.conf is read relative to this path and +all libraries are sought relative to this path, too (a.k.a. a virtual chroot). + +Defaults to '/'. + +=item B<--verbose> + +Prints info about the files as they are being scanned. + +=item B<--version> + +Prints the version and exits. + +=back + +=cut + diff --git a/src/bin/slxsettings b/src/bin/slxsettings new file mode 100755 index 00000000..8c6a823d --- /dev/null +++ b/src/bin/slxsettings @@ -0,0 +1,381 @@ +#! /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/ +# ----------------------------------------------------------------------------- +# slxsettings +# - OpenSLX-script to show & change local settings +# ----------------------------------------------------------------------------- +use strict; +use warnings; + +my $abstract = q[ +slxsettings + This script can be used to show or change the local settings for OpenSLX. + + Any cmdline-argument passed to this script will change the local OpenSLX + settings file (usually /etc/opt/openslx/settings). + + If you invoke the script without any arguments, it will print the current + settings and exit. + + Please use the --man option in order to read the full manual. +]; + +# add the lib-folder and the folder this script lives in to perl's search +# path for modules: +use FindBin; +use lib "$FindBin::RealBin/../lib"; +use lib "$FindBin::RealBin"; +# development path to config-db stuff + +use Config::General; +use Getopt::Long qw(:config pass_through); +use Pod::Usage; + +use OpenSLX::Basics; +use OpenSLX::Utils; + +my (@reset, %givenSettings, %option); + +GetOptions( + 'quiet' => \$option{quiet}, + 'help|?' => \$option{helpReq}, + 'man' => \$option{manReq}, + 'version' => \$option{versionReq}, +); +pod2usage(-msg => $abstract, -verbose => 0, -exitval => 1) if $option{helpReq}; +pod2usage(-verbose => 2) if $option{manReq}; +if ($option{versionReq}) { + system('slxversion'); + exit 1; +} + +if ($> != 0) { + die _tr("Sorry, this script can only be executed by the superuser!\n"); +} + +openslxInit() or pod2usage(2); + +# some settings must match a certain pattern: +my %configPattern = ( + 'db-type' => '(SQLite|mysql)', +); + +# the remaining cmdline arguments are set or reset actions, each followed +# by a single argument: +while (scalar @ARGV) { + my $action = shift || ''; + my $arg = shift || ''; + if ($action eq 'set') { + if ($arg !~ m[^([-\w]+)=(.+)$]) { + die _tr( + "set-argument '%s' has unknown format, expected '=!'", + $arg + ); + } + $givenSettings{$1} = $2; + } + elsif ($action eq 'reset') { + push @reset, $arg; + } + else { + die _tr(unshiftHereDoc(<<' END-OF-HERE'), $arg, $0); + action '%s' is not understood! Known actions are: + set + reset + Try '%s --help' for more info. + END-OF-HERE + } +} + +# fetch current content of local settings file... +my $fileName = "$openslxConfig{'config-path'}/settings"; +if (!-e $fileName) { + # create empty default settings file with tight mode (root-only access) + # [I know this isn't *secure* as such, but it's still better than nothing] + slxsystem("touch $fileName && chmod 0600 $fileName"); +} +my $configObj = Config::General->new( + -ConfigFile => $fileName, + -SplitDelimiter => '\s*=\s*', + -SplitPolicy => 'custom', + -StoreDelimiter => '=', +); +my %settings = $configObj->getall(); + +my %changed; + +# ...set new values... +foreach my $key (keys %givenSettings) { + my $value = $givenSettings{$key}; + next if !defined $value; + if (!exists $openslxConfig{$key}) { + die _tr("option '%s' is not known!", $key); + } + if ($key =~ m{^(base-path|config-path)$}) { + die _tr("option '%s' is fixed!", $key); + } + if (exists $configPattern{$key} && $value !~ m{$configPattern{$key}}) { + die _tr( + "option '%s' must match pattern '%s'!", $key, $configPattern{$key} + ); + } + + vlog(0, _tr("setting %s to '%s'", $key, $value)) unless $option{quiet}; + my $externalKey = externalKeyFor($key); + if (!exists $settings{$externalKey} || $settings{$externalKey} ne $value) { + $settings{$externalKey} = $value; + } + $changed{$key}++; +} + +# reset specified keys to fall back to default: +foreach my $key (@reset) { + my $externalKey = externalKeyFor($key); + if (exists $settings{$externalKey}) { + delete $settings{$externalKey}; + vlog(0, + _tr("removing option '%s' from local settings", $key)) + unless $option{quiet}; + } else { + vlog(0, + _tr("option '%s' didn't exist in local settings!", $key)) + unless $option{quiet}; + } + $changed{$key}++; +} + +# ... and write local settings file if necessary +if (keys %changed) { + $configObj->save_file($fileName, \%settings); + + openslxInit(); + + foreach my $key (keys %changed) { + changedHandler($key, $openslxConfig{$key}); + } +} + +if (!keys %changed) { + print _tr("paths fixed at installation time:\n"); + print qq[\tbase-path='$openslxConfig{'base-path'}'\n]; + print qq[\tconfig-path='$openslxConfig{'config-path'}'\n]; + my $text = + keys %changed + ? "resulting base settings (cmdline options):\n" + : "current base settings (cmdline options):\n"; + print $text; + my @baseSettings = grep { exists $cmdlineConfig{$_} } keys %openslxConfig; + foreach my $key (sort @baseSettings) { + my $val = $openslxConfig{$key} || ''; + print qq[\t$key='$val'\n]; + } + print _tr("extended settings:\n"); + my @extSettings = grep { !exists $cmdlineConfig{$_} } keys %openslxConfig; + foreach my $key (sort @extSettings) { + next if $key =~ m[^(base-path|config-path)$]; + my $val = $openslxConfig{$key}; + if (defined $val) { + print qq[\t$key='$val'\n]; + } + else { + print qq[\t$key=\n]; + } + } +} + +sub externalKeyFor +{ + my $key = shift; + + $key =~ tr[-][_]; + return "SLX_" . uc($key); +} + +sub changedHandler +{ + my $key = shift; + my $value = shift; + + # invoke a key-specific change handler if it exists: + $key =~ tr[-][_]; + + # we do the following function call in an eval as that function may simply + # not exist: + eval { + no strict 'refs'; ## no critic (ProhibitNoStrict) + "${key}_changed_handler"->(); + }; + + return; +} + +sub private_path_changed_handler +{ + # create the default config folders (for default system only): + require OpenSLX::ConfigFolder; + OpenSLX::ConfigFolder::createConfigFolderForDefaultSystem(); + + return; +} + +=head1 NAME + +slxsettings - OpenSLX-script to show & change local settings + +=head1 SYNOPSIS + +slxsettings [options] [action ...] + +=head3 Script Actions + + set sets the option to the given value + reset resets the given option to its default + +=head3 List of Known Option Names + + db-name= name of database + db-spec= full DBI-specification of database + db-type= type of database to connect to + locale= locale to use for translations + log-level= level of logging verbosity (0-3) + logfile= file to write logging output to + private-path= path to private data + public-path= path to public (client-accesible) data + temp-path= path to temporary data + +=head3 General Options + + --help brief help message + --man full documentation + --quiet do not print anything + --version show version + +=head3 Actions + +=over 8 + +=item B<< set = >> + +sets the specified option to the given value + +=item B<< reset >> + +removes the given setting from the local settings (resets it to its default +value) + +=back + +=head1 DESCRIPTION + +B can be used to show or change the local settings for OpenSLX. + +Any cmdline-argument passed to this script will change the local OpenSLX +settings file (usually /etc/opt/openslx/settings). + +If you invoke the script without any arguments, it will print the current +settings and exit. + +=head1 OPTIONS + +=head3 Known Option Names + +=over 8 + +=item B<< db-name= >> + +Gives the name of the database to connect to. + +Default is $SLX_DB_NAME (usually C). + +=item B<< db-spec= >> + +Gives the full DBI-specification of database to connect to. Content depends +on the db-type. + +Default is $SLX_DB_SPEC (usually empty as it will be built automatically). + +=item B<< db-type= >> + +Sets the type of database to connect to (SQLite, mysql, ...). + +Default $SLX_DB_TYPE (usually C). + +=item B<< locale= >> + +Sets the locale to use for translations. + +Defaults to the system's standard locale. + +=item B<< logfile= >> + +Specifies a file where logging output will be written to. + +Default is to log to STDERR. + +=item B<< private-path= >> + +Sets path to private data, where the config-db, vendor_oses and configurational +extensions will be stored. + +Default is $SLX_PRIVATE_PATH (usually F. + +=item B<< public-path= >> + +Sets path to public (client-accesible) data. + +Default is $SLX_PUBLIC_PATH (usually F. + +=item B<< temp-path= >> + +Sets path to temporary data. + +Default is $SLX_TEMP_PATH (usually F. + +=item B<< log-level= >> + +Sets the level of logging verbosity (0-3). +Prints additional output for debugging. N is a number between 0 and 3. Level +1 provides more information than the default, while 2 provides traces. With +level 3 you get extreme debug output, e.g. database commands are printed. + +Default is $SLX_VERBOSE_LEVEL (usually 0, no logging). + +=back + +=head3 General Options + +=over 8 + +=item B< --help> + +Prints a brief help message and exits. + +=item B< --man> + +Prints the manual page and exits. + +=item B< --quiet> + +Runs the script without printing anything. + +=item B< --version> + +Prints the version and exits. + +=back + +=head1 SEE ALSO + +slxos-setup, slxos-export, slxconfig, slxconfig-demuxer + +=cut + -- cgit v1.2.3-55-g7522