diff options
49 files changed, 997 insertions, 765 deletions
@@ -14,6 +14,7 @@ # - OpenSLX-rewrite of ldd that works on multiple architectures. # ----------------------------------------------------------------------------- use strict; +use warnings; my $abstract = q[ slxldd @@ -25,14 +26,14 @@ slxldd required by a binary of the x86_64 target system. ]; -use File::Glob ':globally'; -use Getopt::Long; -use Pod::Usage; - # 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; my ( @@ -104,8 +105,10 @@ sub fetchLoaderConfigFile { my $ldConfFile = shift; - open(LDCONF, "< $ldConfFile"); - while (<LDCONF>) { + my $ldconfFH; + open($ldconfFH, '<', $ldConfFile) + or die(_tr("unable to open file '%s' (%s)", $ldConfFile, $!)); + while (<$ldconfFH>) { chomp; if (/^\s*include\s+(.+?)\s*$/i) { foreach my $incFile (<$rootPath$1>) { @@ -119,7 +122,8 @@ sub fetchLoaderConfigFile push @libFolders, "$rootPath$_"; } } - close LDCONF; + close $ldconfFH + or die(_tr("unable to close file '%s' (%s)", $ldConfFile, $!)); } sub fetchLoaderConfig diff --git a/bin/slxsettings b/bin/slxsettings index e753ad99..278cb2c2 100755 --- a/bin/slxsettings +++ b/bin/slxsettings @@ -14,6 +14,7 @@ # - OpenSLX-script to show & change local settings # ----------------------------------------------------------------------------- use strict; +use warnings; my $abstract = q[ slxsettings @@ -28,9 +29,6 @@ slxsettings Please use the --man option in order to read the full manual. ]; -use Getopt::Long qw(:config pass_through); -use Pod::Usage; - # add the lib-folder and the folder this script lives in to perl's search # path for modules: use FindBin; @@ -38,9 +36,13 @@ use lib "$FindBin::RealBin/../lib"; use lib "$FindBin::RealBin"; # development path to config-db stuff +use Getopt::Long qw(:config pass_through); +use Pod::Usage; + use OpenSLX::Basics; use OpenSLX::Utils; + my ($quiet, @reset, $helpReq, $manReq, $versionReq,); GetOptions( @@ -111,11 +113,8 @@ foreach my $key (@reset) { # ... and write local settings file if necessary if (keys %changed) { - my $f = "$openslxConfig{'config-path'}/settings"; - open(SETTINGS, "> $f") - or die _tr("Unable to write local settings file '%s' (%s)", $f, $!); - print SETTINGS $settings; - close(SETTINGS); + my $fileName = "$openslxConfig{'config-path'}/settings"; + spitFile($fileName, $settings); openslxInit(); @@ -135,13 +134,15 @@ if (!keys %changed) { print $text; my @baseSettings = grep { exists $cmdlineConfig{$_} } keys %openslxConfig; foreach my $key (sort @baseSettings) { - print qq[\t--$key='$openslxConfig{$key}'\n]; + 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)$]; - print qq[\t$key='$openslxConfig{$key}'\n]; + my $val = $openslxConfig{$key} || ''; + print qq[\t$key='$val'\n]; } } diff --git a/config-db/OpenSLX/ConfigDB.pm b/config-db/OpenSLX/ConfigDB.pm index 5518d230..e9940fd1 100644 --- a/config-db/OpenSLX/ConfigDB.pm +++ b/config-db/OpenSLX/ConfigDB.pm @@ -11,9 +11,14 @@ package OpenSLX::ConfigDB; use strict; -use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); +use warnings; + +our (@ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS, $VERSION); $VERSION = 1; # API-version +use Exporter; +@ISA = qw(Exporter); + ################################################################################ ### This module defines the data abstraction layer for the OpenSLX configuration ### database. @@ -28,9 +33,6 @@ $VERSION = 1; # API-version ### - support methods ################################################################################ -use Exporter; -@ISA = qw(Exporter); - my @supportExports = qw( isAttribute mergeAttributes pushAttributes externalIDForSystem externalIDForClient externalConfigNameForClient @@ -44,7 +46,6 @@ my @supportExports = qw( ################################################################################ ### private stuff ################################################################################ -use Carp; use OpenSLX::Basics; use OpenSLX::DBSchema; @@ -106,7 +107,7 @@ sub _checkAndUpgradeDBSchemaIfNecessary $changeDescr->{'cols'} ); } else { - confess _tr('UnknownDbSchemaCommand', $cmd); + croak _tr('UnknownDbSchemaCommand', $cmd); } } } @@ -162,29 +163,25 @@ sub connect $dbType = $dbTypeMap{$lcType}; } + my $dbModuleName = "OpenSLX/MetaDB/$dbType.pm"; my $dbModule = "OpenSLX::MetaDB::$dbType"; - unless (eval "require $dbModule") { + unless (eval { require $dbModuleName } ) { if ($! == 2) { die _tr( "Unable to load DB-module <%s>\nthat database type is not supported (yet?)\n", - $dbModule + $dbModuleName ); } else { - die _tr("Unable to load DB-module <%s> (%s)\n", $dbModule, $@); + die _tr("Unable to load DB-module <%s> (%s)\n", $dbModuleName, $@); } } - my $modVersion = $dbModule->VERSION; - if ($modVersion < $VERSION) { - confess _tr( - 'Could not load module <%s> (Version <%s> required, but <%s> found)', - $dbModule, $VERSION, $modVersion); - } my $metaDB = $dbModule->new(); - if (!eval '$metaDB->connect($dbParams);1') { - warn _tr("Unable to connect to DB-module <%s>\n%s", $dbModule, $@); + if (!$metaDB->connect($dbParams)) { + warn _tr("Unable to connect to DB-module <%s>\n%s", $dbModuleName, $@); warn _tr("These DB-modules seem to work ok:"); foreach my $dbMod ('CSV', 'mysql', 'SQLite') { - if (eval "require DBD::$dbMod;") { + my $fullDbModName = "DBD/$dbMod.pm"; + if (eval { require $fullDbModName }) { vlog(0, "\t$dbMod\n"); } } @@ -436,7 +433,7 @@ sub incrementExportCounterForVendorOS $self->start_transaction(); my $vendorOS = $self->fetchVendorOSByID($id); - return undef unless defined $vendorOS; + return unless defined $vendorOS; my $exportCounter = $vendorOS->{export_counter} + 1; $self->changeVendorOS($id, {'export_counter' => $exportCounter}); $self->commit_transaction(); @@ -451,7 +448,7 @@ sub incrementGlobalCounter $self->start_transaction(); my $value = $self->fetchGlobalInfo($counterName); - return undef unless defined $value; + return unless defined $value; my $newValue = $value + 1; $self->changeGlobalInfo($counterName, $newValue); $self->commit_transaction(); @@ -499,10 +496,10 @@ sub addSystem my $valRows = _aref(shift); foreach my $valRow (@$valRows) { - if (!length($valRow->{kernel})) { + if (!defined $valRow->{kernel} || !length($valRow->{kernel})) { $valRow->{kernel} = 'vmlinuz'; } - if (!length($valRow->{label})) { + if (!defined $valRow->{label} || !length($valRow->{label})) { $valRow->{label} = $valRow->{name}; } } @@ -958,7 +955,7 @@ sub aggregatedSystemFileInfoFor "$openslxConfig{'private-path'}/stage1/$vendorOS->{name}/boot"; $info->{'kernel-file'} = "$kernelPath/$system->{kernel}"; - my $exportURI = $export->{'uri'}; + my $exportURI = $export->{'uri'} || ''; if ($exportURI !~ m[\w]) { # auto-generate export_uri if none has been given: my $type = $export->{'type'}; @@ -987,9 +984,11 @@ sub mergeAttributes my $source = shift; foreach my $key (grep { isAttribute($_) } keys %$source) { - if (length($source->{$key}) > 0 && length($target->{$key}) == 0) { - vlog(3, _tr("merging %s (val=%s)", $key, $source->{$key})); - $target->{$key} = $source->{$key}; + my $sourceVal = $source->{$key} || ''; + my $targetVal = $target->{$key} || ''; + if (length($sourceVal) > 0 && length($targetVal) == 0) { + vlog(3, _tr("merging %s (val=%s)", $key, $sourceVal)); + $target->{$key} = $sourceVal; } } } @@ -1000,9 +999,10 @@ sub pushAttributes my $source = shift; foreach my $key (grep { isAttribute($_) } keys %$source) { - if (length($source->{$key}) > 0) { - vlog(3, _tr("pushing %s (val=%s)", $key, $source->{$key})); - $target->{$key} = $source->{$key}; + my $sourceVal = $source->{$key} || ''; + if (length($sourceVal) > 0) { + vlog(3, _tr("pushing %s (val=%s)", $key, $sourceVal)); + $target->{$key} = $sourceVal; } } } diff --git a/config-db/OpenSLX/DBSchema.pm b/config-db/OpenSLX/DBSchema.pm index 0fbce67a..1454390a 100644 --- a/config-db/OpenSLX/DBSchema.pm +++ b/config-db/OpenSLX/DBSchema.pm @@ -14,7 +14,9 @@ package OpenSLX::DBSchema; use strict; -use vars qw(@ISA @EXPORT $VERSION); +use warnings; + +our (@ISA, @EXPORT, $VERSION); use Exporter; $VERSION = 0.01; @@ -24,7 +26,7 @@ $VERSION = 0.01; $DbSchema %DbSchemaHistory ); -use vars qw($DbSchema %DbSchemaHistory); +our ($DbSchema, %DbSchemaHistory); # configurable attributes for system, client and group: my @sharedAttributes = ( diff --git a/config-db/OpenSLX/Export/DHCP/ISC.pm b/config-db/OpenSLX/Export/DHCP/ISC.pm index 194876fa..2e7aa01b 100644 --- a/config-db/OpenSLX/Export/DHCP/ISC.pm +++ b/config-db/OpenSLX/Export/DHCP/ISC.pm @@ -13,14 +13,14 @@ # ----------------------------------------------------------------------------- package OpenSLX::Export::DHCP::ISC; -use vars qw(@ISA $VERSION); -$VERSION = 1.01; # API-version . implementation-version +use strict; +use warnings; + +our $VERSION = 1.01; # API-version . implementation-version ################################################################################ ### This class provides an ISC specific implementation for DHCP export. ################################################################################ -use strict; -use Carp; use OpenSLX::Basics; ################################################################################ diff --git a/config-db/OpenSLX/MetaDB/Base.pm b/config-db/OpenSLX/MetaDB/Base.pm index 2738cb16..2aa1c3f2 100644 --- a/config-db/OpenSLX/MetaDB/Base.pm +++ b/config-db/OpenSLX/MetaDB/Base.pm @@ -14,11 +14,11 @@ package OpenSLX::MetaDB::Base; use strict; +use warnings; -use vars qw($VERSION); -$VERSION = 1.01; # API-version . implementation-version +our $VERSION = 1.01; # API-version . implementation-version -use Carp; +use OpenSLX::Basics; ################################################################################ ### basic functions diff --git a/config-db/OpenSLX/MetaDB/CSV.pm b/config-db/OpenSLX/MetaDB/CSV.pm index 104a4d98..ef96833a 100644 --- a/config-db/OpenSLX/MetaDB/CSV.pm +++ b/config-db/OpenSLX/MetaDB/CSV.pm @@ -14,8 +14,8 @@ package OpenSLX::MetaDB::CSV; use strict; -use vars qw($VERSION); -$VERSION = 1.01; # API-version . implementation-version +use warnings; + use base qw(OpenSLX::MetaDB::DBI); ################################################################################ @@ -24,12 +24,9 @@ use base qw(OpenSLX::MetaDB::DBI); ### - each table will be stored into a CSV file. ### - by default all files will be created inside a 'openslxdata-csv' directory. ################################################################################ -use strict; -use Carp; use Fcntl qw(:DEFAULT :flock); use DBD::CSV 0.22; use OpenSLX::Basics; -use OpenSLX::MetaDB::DBI 1; ################################################################################ ### implementation diff --git a/config-db/OpenSLX/MetaDB/DBI.pm b/config-db/OpenSLX/MetaDB/DBI.pm index ea0b66f1..91d774c7 100644 --- a/config-db/OpenSLX/MetaDB/DBI.pm +++ b/config-db/OpenSLX/MetaDB/DBI.pm @@ -14,14 +14,12 @@ package OpenSLX::MetaDB::DBI; use strict; -use vars qw($VERSION); -$VERSION = 1.01; # API-version . implementation-version +use warnings; + use base qw(OpenSLX::MetaDB::Base); -use Carp; use DBI; use OpenSLX::Basics; -use OpenSLX::MetaDB::Base 1; ################################################################################ ### basics @@ -783,7 +781,7 @@ sub schemaFetchDBVersion eval { $dbh->selectrow_hashref('SELECT schema_version FROM meta'); }; return 0 if $@; # no database access possible - return undef unless defined $row; + return unless defined $row; # no entry in meta-table return $row->{schema_version}; } diff --git a/config-db/OpenSLX/MetaDB/SQLite.pm b/config-db/OpenSLX/MetaDB/SQLite.pm index 65e1668c..d6681ce6 100644 --- a/config-db/OpenSLX/MetaDB/SQLite.pm +++ b/config-db/OpenSLX/MetaDB/SQLite.pm @@ -14,19 +14,16 @@ package OpenSLX::MetaDB::SQLite; use strict; -use vars qw($VERSION); -$VERSION = 1.01; # API-version . implementation-version +use warnings; + use base qw(OpenSLX::MetaDB::DBI); ################################################################################ ### This class provides a MetaDB backend for SQLite databases. ### - by default the db will be created inside a 'openslxdata-sqlite' directory. ################################################################################ -use strict; -use Carp; use DBD::SQLite; use OpenSLX::Basics; -use OpenSLX::MetaDB::DBI 1; ################################################################################ ### implementation @@ -52,16 +49,11 @@ sub connect $dbSpec = "dbname=$dbPath/$openslxConfig{'db-name'}"; } vlog(1, "trying to connect to SQLite-database <$dbSpec>"); - eval('require DBD::SQLite; 1;') - or die _tr( - qq[%s doesn't seem to be installed, -so there is no support for %s available, sorry!\n%s], 'DBD::SQLite', 'SQLite', - $@ - ); $self->{'dbh'} = DBI->connect("dbi:SQLite:$dbSpec", undef, undef, {PrintError => 0, AutoCommit => 1}) or die _tr("Cannot connect to database <%s> (%s)", $dbSpec, $DBI::errstr); + return 1; } sub schemaRenameTable @@ -77,7 +69,7 @@ sub schemaRenameTable my $sql = "ALTER TABLE $oldTable RENAME TO $newTable"; vlog(3, $sql); $dbh->do($sql) - or confess _tr(q[Can't rename table <%s> (%s)], $oldTable, $dbh->errstr); + or croak(_tr(q[Can't rename table <%s> (%s)], $oldTable, $dbh->errstr)); } sub schemaAddColumns @@ -99,8 +91,8 @@ sub schemaAddColumns my $sql = "ALTER TABLE $table ADD COLUMN $colDescrString"; vlog(3, $sql); $dbh->do($sql) - or confess _tr(q[Can't add column to table <%s> (%s)], $table, - $dbh->errstr); + or croak(_tr(q[Can't add column to table <%s> (%s)], $table, + $dbh->errstr)); } # if default values have been provided, we apply them now: if (defined $newColDefaultVals) { diff --git a/config-db/OpenSLX/MetaDB/mysql.pm b/config-db/OpenSLX/MetaDB/mysql.pm index 195f9870..769506d1 100644 --- a/config-db/OpenSLX/MetaDB/mysql.pm +++ b/config-db/OpenSLX/MetaDB/mysql.pm @@ -14,19 +14,16 @@ package OpenSLX::MetaDB::mysql; use strict; -use vars qw($VERSION); -$VERSION = 1.01; # API-version . implementation-version +use warnings; + use base qw(OpenSLX::MetaDB::DBI); ################################################################################ ### This class provides a MetaDB backend for mysql databases. ### - by default the db will be created inside a 'openslxdata-mysql' directory. ################################################################################ -use strict; -use Carp; use DBD::mysql; use OpenSLX::Basics; -use OpenSLX::MetaDB::DBI 1; ################################################################################ ### implementation diff --git a/config-db/slxconfig b/config-db/slxconfig index cb6c912e..07ff6473 100755 --- a/config-db/slxconfig +++ b/config-db/slxconfig @@ -11,6 +11,7 @@ # General information about OpenSLX can be found at http://openslx.org/ # ----------------------------------------------------------------------------- use strict; +use warnings; my $abstract = q[ slxconfig @@ -143,7 +144,7 @@ sub dumpElements '', map { my $spc = ' 'x25; - my $val = $elem->{$_}; + my $val = $elem->{$_} || ''; $val =~ s[\n][\n\t$spc ]g; "\t$_" .substr($spc, length($_)) @@ -319,12 +320,12 @@ sub addSystemToConfigDB my $systemData = parseKeyValueArgs(\@systemKeys, 'system', @_); $systemData->{name} = $systemName; - if (!length($systemData->{export})) { - $systemData->{export} = $systemName; + my $exportName = $systemData->{export} || ''; + delete $systemData->{export}; + if (!length($exportName)) { + $exportName = $systemName; # try falling back to given system name } - my $exportName = $systemData->{export}; - delete $systemData->{export}; my $export = $openslxDB->fetchExportByFilter({ 'name' => $exportName }); if (!defined $export) { diff --git a/config-db/slxconfig-demuxer b/config-db/slxconfig-demuxer index d3b53541..c227d510 100755 --- a/config-db/slxconfig-demuxer +++ b/config-db/slxconfig-demuxer @@ -14,6 +14,7 @@ # - OpenSLX configuration demultiplexer # ----------------------------------------------------------------------------- use strict; +use warnings; my $abstract = q[ slxconfig-demuxer @@ -217,9 +218,14 @@ sub digestAttributes # facilitate comparing different attribute hashes. my $attrs = shift; - my $attrsAsString = join ';', map { "$_=$attrs->{$_}"; } - sort { $a cmp $b } - grep { isAttribute($_) } keys %$attrs; + my $attrsAsString + = join ';', + map { + my $val = $attrs->{$_} || ''; + "$_=$val"; + } + sort { $a cmp $b } + grep { isAttribute($_) } keys %$attrs; vlog(3, "Attribute-string: $attrsAsString"); use Digest::MD5 qw(md5_hex); @@ -234,27 +240,27 @@ sub writeAttributesToFile return if $dryRun; - # Overwrite attribute file even if it exists, to make sure that our users - # will never again try to fiddle with machine-setup directly the - # file-system. From now on the DB is the keeper of that info. - open(ATTRS, "> $fileName") or die "unable to write to $fileName"; + my $content = "# attributes set by slxconfig-demuxer:\n"; my @attrs = ( $grepForAttributes - ? sort grep { isAttribute($_) } keys %$attrHash - : keys %$attrHash + ? sort grep { isAttribute($_) } keys %$attrHash + : keys %$attrHash ); - print ATTRS "# attributes set by slxconfig-demuxer:\n"; foreach my $attr (@attrs) { - if (length($attrHash->{$attr}) > 0) { + my $attrVal = $attrHash->{$attr} || ''; + if (length($attrVal) > 0) { my $externalAttrName = externalAttrName($attr); - print ATTRS qq[$externalAttrName="$attrHash->{$attr}"\n]; + $content .= qq[$externalAttrName="$attrVal"\n]; } } - close(ATTRS); + # Overwrite attribute file even if it exists, to make sure that our users + # will never again try to fiddle with machine-setup directly the + # file-system. From now on the DB is the keeper of that info. + spitFile($fileName, $content); if ($openslxConfig{'verbose-level'} > 2) { - print "--- START OF $fileName ---\n"; - system("cat $fileName"); - print "--- END OF $fileName --- \n"; + vlog(0, "--- START OF $fileName ---"); + vlog(0, $content); + vlog(0, "--- END OF $fileName --- "); } } @@ -265,11 +271,11 @@ sub writeSlxConfigToFile return if $dryRun; - open(SLXCONF, "> $fileName") or die "unable to write to $fileName"; + my $content = ''; foreach my $key (sort keys %$slxConf) { - print SLXCONF qq[$key="$slxConf->{$key}"\n]; + $content .= qq[$key="$slxConf->{$key}"\n]; } - close(SLXCONF); + spitFile($fileName, $content); } sub copyExternalSystemConfig @@ -372,11 +378,13 @@ sub writePXEMenus foreach my $client (@clients) { my $externalClientID = externalIDForClient($client); my $pxeFile = "$pxeConfigPath/$externalClientID"; - my $clientAppend = $client->{kernel_params}; + my $clientAppend = $client->{kernel_params} || ''; vlog(1, _tr("writing PXE-file %s", $pxeFile)); next if $dryRun; - open(PXE, ">$pxeFile") or die "unable to write to $pxeFile"; - print PXE $pxeTemplate; + my $pxeFH; + open($pxeFH, '>', $pxeFile) + or croak _tr("unable to create file '%s' (%s)\n", $pxeFile, $!); + print $pxeFH $pxeTemplate; my %systemIDs; @systemIDs{$openslxDB->aggregatedSystemIDsOfClient($client)} = (); my @systemInfos = grep { exists $systemIDs{$_->{id}} } @infos; @@ -387,13 +395,14 @@ sub writePXEMenus my $append = $info->{kernel_params}; $append .= " initrd=$extID/$info->{'initramfs-name'}"; $append .= " $clientAppend"; - print PXE "LABEL openslx-$info->{'external-id'}\n"; - print PXE "\tMENU LABEL ^$info->{label}\n"; - print PXE "\tKERNEL $extID/$kernelName\n"; - print PXE "\tAPPEND $append\n"; - print PXE "\tIPAPPEND 1\n"; + print $pxeFH "LABEL openslx-$info->{'external-id'}\n"; + print $pxeFH "\tMENU LABEL ^$info->{label}\n"; + print $pxeFH "\tKERNEL $extID/$kernelName\n"; + print $pxeFH "\tAPPEND $append\n"; + print $pxeFH "\tIPAPPEND 1\n"; } - close(PXE); + close($pxeFH) + or croak _tr("unable to close file '%s' (%s)\n", $pxeFile, $!); } } @@ -430,10 +439,10 @@ sub generateInitalRamFS # generate initramfs-setup file (with settings relevant for initramfs only): my $initramfsAttrFile = "$tempPath/initramfs-setup"; my $initramfsAttrs = { - 'ramfs_fsmods' => "$info->{'attr_ramfs_fsmods'}", - 'ramfs_nicmods' => "$info->{'attr_ramfs_nicmods'}", - 'ramfs_screen' => "$info->{'attr_ramfs_screen'}", - 'rootfs' => "$info->{'export-uri'}", + 'ramfs_fsmods' => $info->{'attr_ramfs_fsmods'} || '', + 'ramfs_nicmods' => $info->{'attr_ramfs_nicmods'} || '', + 'ramfs_screen' => $info->{'attr_ramfs_screen'} || '', + 'rootfs' => $info->{'export-uri'} || '', }; writeAttributesToFile($initramfsAttrs, $initramfsAttrFile, 0); # and pass it to mkdxsinitrd: @@ -478,7 +487,7 @@ sub writeDhcpConfig { vlog(0, _tr("sorry, exporting dhcp data is not implemented yet!")); my $dhcpModule = "OpenSLX::Export::DHCP::$dhcpType"; - if (!eval "require $dhcpModule") { + if (!eval { require $dhcpModule } ) { die _tr("unable to load DHCP-Export backend '%s'! (%s)\n", $dhcpModule, $@); } diff --git a/installer/OpenSLX/OSExport/BlockDevice/AoE.pm b/installer/OpenSLX/OSExport/BlockDevice/AoE.pm index c8aad4ec..2113ef5c 100644 --- a/installer/OpenSLX/OSExport/BlockDevice/AoE.pm +++ b/installer/OpenSLX/OSExport/BlockDevice/AoE.pm @@ -14,12 +14,11 @@ # ----------------------------------------------------------------------------- package OpenSLX::OSExport::BlockDevice::AoE; -use vars qw($VERSION); +use strict; +use warnings; + use base qw(OpenSLX::OSExport::BlockDevice::Base); -$VERSION = 1.01; # API-version . implementation-version -use strict; -use Carp; use File::Basename; use OpenSLX::Basics; use OpenSLX::ConfigDB qw(:support); @@ -32,7 +31,6 @@ use OpenSLX::Utils; # # - ################################################################################ ### interface methods ################################################################################ @@ -66,10 +64,9 @@ sub generateExportURI my $self = shift; my $export = shift; - my $server = - length($export->{server_ip}) - ? $export->{server_ip} - : generatePlaceholderFor('serverip'); + my $serverIP = $export->{server_ip} || ''; + my $server + = length($serverIP) ? $serverIP : generatePlaceholderFor('serverip'); $server .= ":$export->{port}" if length($export->{port}); return "aoe://$server"; diff --git a/installer/OpenSLX/OSExport/BlockDevice/Base.pm b/installer/OpenSLX/OSExport/BlockDevice/Base.pm index 938dc6db..ef59f86b 100644 --- a/installer/OpenSLX/OSExport/BlockDevice/Base.pm +++ b/installer/OpenSLX/OSExport/BlockDevice/Base.pm @@ -13,14 +13,12 @@ # ----------------------------------------------------------------------------- package OpenSLX::OSExport::BlockDevice::Base; -use vars qw($VERSION); -$VERSION = 1.01; # API-version . implementation-version - use strict; -use Carp; +use warnings; + +our $VERSION = 1.01; # API-version . implementation-version -use OpenSLX::Basics; -use OpenSLX::Utils; +use Carp qw(confess); ################################################################################ ### interface methods diff --git a/installer/OpenSLX/OSExport/BlockDevice/NBD.pm b/installer/OpenSLX/OSExport/BlockDevice/NBD.pm index 8afaa97f..89f10b66 100644 --- a/installer/OpenSLX/OSExport/BlockDevice/NBD.pm +++ b/installer/OpenSLX/OSExport/BlockDevice/NBD.pm @@ -14,12 +14,11 @@ # ----------------------------------------------------------------------------- package OpenSLX::OSExport::BlockDevice::NBD; -use vars qw($VERSION); +use strict; +use warnings; + use base qw(OpenSLX::OSExport::BlockDevice::Base); -$VERSION = 1.01; # API-version . implementation-version -use strict; -use Carp; use File::Basename; use OpenSLX::Basics; use OpenSLX::ConfigDB qw(:support); @@ -59,10 +58,9 @@ sub generateExportURI my $self = shift; my $export = shift; - my $server = - length($export->{server_ip}) - ? $export->{server_ip} - : generatePlaceholderFor('serverip'); + my $serverIP = $export->{server_ip} || ''; + my $server + = length($serverIP) ? $serverIP : generatePlaceholderFor('serverip'); $server .= ":$export->{port}" if length($export->{port}); return "nbd://$server"; diff --git a/installer/OpenSLX/OSExport/Distro/Any.pm b/installer/OpenSLX/OSExport/Distro/Any.pm index 828e4990..976bbadf 100644 --- a/installer/OpenSLX/OSExport/Distro/Any.pm +++ b/installer/OpenSLX/OSExport/Distro/Any.pm @@ -13,14 +13,12 @@ # ----------------------------------------------------------------------------- package OpenSLX::OSExport::Distro::Any; -use vars qw($VERSION); +use strict; +use warnings; + use base qw(OpenSLX::OSExport::Distro::Base); -$VERSION = 1.01; # API-version . implementation-version -use strict; -use Carp; use OpenSLX::Basics; -use OpenSLX::OSExport::Distro::Base 1; ################################################################################ ### implementation diff --git a/installer/OpenSLX/OSExport/Distro/Base.pm b/installer/OpenSLX/OSExport/Distro/Base.pm index 645523c6..f1986ee5 100644 --- a/installer/OpenSLX/OSExport/Distro/Base.pm +++ b/installer/OpenSLX/OSExport/Distro/Base.pm @@ -14,13 +14,12 @@ # ----------------------------------------------------------------------------- package OpenSLX::OSExport::Distro::Base; -use vars qw($VERSION); -$VERSION = 1.01; # API-version . implementation-version - use strict; -use Carp; -use File::Basename; -use OpenSLX::Basics; +use warnings; + +our $VERSION = 1.01; # API-version . implementation-version + +use Carp qw(confess); ################################################################################ ### interface methods diff --git a/installer/OpenSLX/OSExport/Distro/Debian.pm b/installer/OpenSLX/OSExport/Distro/Debian.pm index 35e7f4c9..5f161902 100644 --- a/installer/OpenSLX/OSExport/Distro/Debian.pm +++ b/installer/OpenSLX/OSExport/Distro/Debian.pm @@ -13,14 +13,12 @@ # ----------------------------------------------------------------------------- package OpenSLX::OSExport::Distro::Debian; -use vars qw($VERSION); +use strict; +use warnings; + use base qw(OpenSLX::OSExport::Distro::Base); -$VERSION = 1.01; # API-version . implementation-version -use strict; -use Carp; use OpenSLX::Basics; -use OpenSLX::OSExport::Distro::Base 1; ################################################################################ ### implementation diff --git a/installer/OpenSLX/OSExport/Distro/Fedora.pm b/installer/OpenSLX/OSExport/Distro/Fedora.pm index 9374678d..0ef3e028 100644 --- a/installer/OpenSLX/OSExport/Distro/Fedora.pm +++ b/installer/OpenSLX/OSExport/Distro/Fedora.pm @@ -13,14 +13,12 @@ # ----------------------------------------------------------------------------- package OpenSLX::OSExport::Distro::Fedora; -use vars qw($VERSION); +use strict; +use warnings; + use base qw(OpenSLX::OSExport::Distro::Base); -$VERSION = 1.01; # API-version . implementation-version -use strict; -use Carp; use OpenSLX::Basics; -use OpenSLX::OSExport::Distro::Base 1; ################################################################################ ### implementation diff --git a/installer/OpenSLX/OSExport/Distro/Gentoo.pm b/installer/OpenSLX/OSExport/Distro/Gentoo.pm index c7d4575f..4d908650 100644 --- a/installer/OpenSLX/OSExport/Distro/Gentoo.pm +++ b/installer/OpenSLX/OSExport/Distro/Gentoo.pm @@ -13,14 +13,12 @@ # ----------------------------------------------------------------------------- package OpenSLX::OSExport::Distro::Gentoo; -use vars qw($VERSION); +use strict; +use warnings; + use base qw(OpenSLX::OSExport::Distro::Base); -$VERSION = 1.01; # API-version . implementation-version -use strict; -use Carp; use OpenSLX::Basics; -use OpenSLX::OSExport::Distro::Base 1; ################################################################################ ### implementation diff --git a/installer/OpenSLX/OSExport/Distro/SUSE.pm b/installer/OpenSLX/OSExport/Distro/SUSE.pm index 7da7656b..1f826159 100644 --- a/installer/OpenSLX/OSExport/Distro/SUSE.pm +++ b/installer/OpenSLX/OSExport/Distro/SUSE.pm @@ -13,14 +13,12 @@ # ----------------------------------------------------------------------------- package OpenSLX::OSExport::Distro::SUSE; -use vars qw($VERSION); +use strict; +use warnings; + use base qw(OpenSLX::OSExport::Distro::Base); -$VERSION = 1.01; # API-version . implementation-version -use strict; -use Carp; use OpenSLX::Basics; -use OpenSLX::OSExport::Distro::Base 1; ################################################################################ ### implementation diff --git a/installer/OpenSLX/OSExport/Distro/Ubuntu.pm b/installer/OpenSLX/OSExport/Distro/Ubuntu.pm index 409bb0cf..8dbaae9e 100644 --- a/installer/OpenSLX/OSExport/Distro/Ubuntu.pm +++ b/installer/OpenSLX/OSExport/Distro/Ubuntu.pm @@ -13,14 +13,12 @@ # ----------------------------------------------------------------------------- package OpenSLX::OSExport::Distro::Ubuntu; -use vars qw($VERSION); +use strict; +use warnings; + use base qw(OpenSLX::OSExport::Distro::Base); -$VERSION = 1.01; # API-version . implementation-version -use strict; -use Carp; use OpenSLX::Basics; -use OpenSLX::OSExport::Distro::Base 1; ################################################################################ ### implementation diff --git a/installer/OpenSLX/OSExport/Engine.pm b/installer/OpenSLX/OSExport/Engine.pm index 5d08c177..31a71b5a 100644 --- a/installer/OpenSLX/OSExport/Engine.pm +++ b/installer/OpenSLX/OSExport/Engine.pm @@ -13,7 +13,10 @@ # ----------------------------------------------------------------------------- package OpenSLX::OSExport::Engine; -use vars qw(@ISA @EXPORT $VERSION); +use strict; +use warnings; + +our (@ISA, @EXPORT, $VERSION); $VERSION = 1.01; # API-version . implementation-version use Exporter; @@ -24,16 +27,14 @@ use Exporter; @supportedExportTypes %supportedDistros ); -use strict; -use Carp; use File::Basename; use OpenSLX::Basics; use OpenSLX::Utils; -use vars qw( - %supportedExportFileSystems %supportedExportBlockDevices - @supportedExportTypes %supportedDistros +our ( + %supportedExportFileSystems, %supportedExportBlockDevices, + @supportedExportTypes, %supportedDistros ); %supportedExportFileSystems = ( diff --git a/installer/OpenSLX/OSExport/FileSystem/Base.pm b/installer/OpenSLX/OSExport/FileSystem/Base.pm index bb6f42d3..0822c458 100644 --- a/installer/OpenSLX/OSExport/FileSystem/Base.pm +++ b/installer/OpenSLX/OSExport/FileSystem/Base.pm @@ -13,14 +13,12 @@ # ----------------------------------------------------------------------------- package OpenSLX::OSExport::FileSystem::Base; -use vars qw($VERSION); -$VERSION = 1.01; # API-version . implementation-version - use strict; -use Carp; +use warnings; + +our $VERSION = 1.01; # API-version . implementation-version -use OpenSLX::Basics; -use OpenSLX::Utils; +use Carp qw(confess); ################################################################################ ### interface methods diff --git a/installer/OpenSLX/OSExport/FileSystem/NFS.pm b/installer/OpenSLX/OSExport/FileSystem/NFS.pm index ffeaeffd..0073d55c 100644 --- a/installer/OpenSLX/OSExport/FileSystem/NFS.pm +++ b/installer/OpenSLX/OSExport/FileSystem/NFS.pm @@ -13,17 +13,15 @@ # ----------------------------------------------------------------------------- package OpenSLX::OSExport::FileSystem::NFS; -use vars qw($VERSION); +use strict; +use warnings; + use base qw(OpenSLX::OSExport::FileSystem::Base); -$VERSION = 1.01; # API-version . implementation-version -use strict; -use Carp; use File::Basename; use OpenSLX::Basics; use OpenSLX::ConfigDB qw(:support); use OpenSLX::Utils; -use OpenSLX::OSExport::FileSystem::Base 1; ################################################################################ ### interface methods @@ -74,11 +72,11 @@ sub generateExportURI my $export = shift; my $vendorOS = shift; - my $server - = length($export->{server_ip}) - ? $export->{server_ip} - : generatePlaceholderFor('serverip'); - $server .= ":$export->{port}" if length($export->{port}); + my $serverIP = $export->{server_ip} || ''; + my $server + = length($serverIP) ? $serverIP : generatePlaceholderFor('serverip'); + my $port = $export->{port} || ''; + $server .= ":$port" if length($port); my $exportPath = "$openslxConfig{'public-path'}/export"; return "nfs://$server$exportPath/nfs/$vendorOS->{name}"; @@ -98,7 +96,7 @@ sub showExportConfigInfo print (('#' x 80)."\n"); print _tr("Please make sure the following line is contained in /etc/exports\nin order to activate the NFS-export of this vendor-OS:\n\t%s\n", - "$self->{engine}->{'export-path'}\t*(ro,no_root_squash,async,no_subtree_check)"); + "$self->{'export-path'}\t*(ro,no_root_squash,async,no_subtree_check)"); print (('#' x 80)."\n"); # TODO : add something a bit more clever here... @@ -120,14 +118,14 @@ sub _copyViaRsync } my $includeExcludeList = $self->_determineIncludeExcludeList(); vlog(1, _tr("using include-exclude-filter:\n%s\n", $includeExcludeList)); - open(RSYNC, "| rsync -av --delete --exclude-from=- $source/ $target") + my $rsyncFH; + open($rsyncFH, '|-', "rsync -av --delete --exclude-from=- $source/ $target") or die _tr("unable to start rsync for source '%s', giving up! (%s)", $source, $!); - print RSYNC $includeExcludeList; - if (!close(RSYNC)) { - die _tr("unable to export to target '%s', giving up! (%s)", - $target, $!); - } + print $rsyncFH $includeExcludeList; + close($rsyncFH) + or die _tr("unable to export to target '%s', giving up! (%s)", + $target, $!); } sub _determineIncludeExcludeList @@ -140,7 +138,8 @@ sub _determineIncludeExcludeList my $distroName = $self->{engine}->{'distro-name'}; my $localFilterFile = "$openslxConfig{'config-path'}/distro-info/$distroName/export-filter"; - my $includeExcludeList = slurpFile($localFilterFile, 1); + my $includeExcludeList + = slurpFile($localFilterFile, { failIfMissing => 0 }); $includeExcludeList .= $self->{engine}->{distro}->{'export-filter'}; $includeExcludeList =~ s[^\s+][]igms; # remove any leading whitespace, as rsync doesn't like it diff --git a/installer/OpenSLX/OSExport/FileSystem/SquashFS.pm b/installer/OpenSLX/OSExport/FileSystem/SquashFS.pm index 48efb45b..6aeb9cd2 100644 --- a/installer/OpenSLX/OSExport/FileSystem/SquashFS.pm +++ b/installer/OpenSLX/OSExport/FileSystem/SquashFS.pm @@ -14,12 +14,11 @@ # ----------------------------------------------------------------------------- package OpenSLX::OSExport::FileSystem::SquashFS; -use vars qw($VERSION); +use strict; +use warnings; + use base qw(OpenSLX::OSExport::FileSystem::Base); -$VERSION = 1.01; # API-version . implementation-version -use strict; -use Carp; use File::Basename; use OpenSLX::Basics; use OpenSLX::ConfigDB qw(:support); @@ -61,11 +60,11 @@ sub exportVendorOS vlog(1, _tr("using include-exclude-filter:\n%s\n", $includeExcludeList)); my $target = $self->{'export-path'}; - my $sourceTime = (stat($source))[9]; - my $targetTime = (stat($target))[9]; + my $sourceTime = (stat($source))[9] || 0; + my $targetTime = (stat($target))[9] || 0; vlog(2, "source-time=$sourceTime target-time=$targetTime"); - if (defined $targetTime && $sourceTime < $targetTime) { + if ($targetTime && $sourceTime < $targetTime) { vlog( 0, "!!! creation of squashfs skipped, as vendor-OS hasn't changed since last export!\n" @@ -115,7 +114,7 @@ sub checkRequirements "unable to find blockdevice-module '%s' for kernel version '%s'.", $blockModName, $kernelVer ); - return undef; + return; } push @blockMods, $blockMod; } @@ -130,7 +129,7 @@ sub checkRequirements if (!defined $squashfsMod) { warn _tr("unable to find squashfs-module for kernel version '%s'.", $kernelVer); - return undef; + return; } push @blockMods, $squashfsMod; if (defined $info) { @@ -205,10 +204,7 @@ sub _createSquashFS # dump filter to a file ... my $filterFile = "/tmp/slx-nbdsquash-filter-$$"; - open(FILTERFILE, "> $filterFile") - or die _tr("unable to create tmpfile '%s' (%s)", $filterFile, $!); - print FILTERFILE $includeExcludeList; - close(FILTERFILE); + spitFile($filterFile, $includeExcludeList); # ... invoke mksquashfs ... vlog(0, _tr("invoking mksquashfs...")); @@ -234,7 +230,8 @@ sub _determineIncludeExcludeList my $distroName = $self->{engine}->{'distro-name'}; my $localFilterFile = "$openslxConfig{'config-path'}/distro-info/$distroName/export-filter"; - my $includeExcludeList = slurpFile($localFilterFile, 1); + my $includeExcludeList + = slurpFile($localFilterFile, { failIfMissing => 0 }); $includeExcludeList .= $self->{engine}->{distro}->{'export-filter'}; $includeExcludeList =~ s[^\s+][]igms; # remove any leading whitespace, as rsync doesn't like it @@ -310,7 +307,7 @@ sub _locateKernelModule if (defined $location) { return followLink($location, $vendorOSPath); } - return undef; + return; } sub _addBlockDeviceTagToExport diff --git a/installer/OpenSLX/OSSetup/Distro/Any_Clone.pm b/installer/OpenSLX/OSSetup/Distro/Any_Clone.pm index 80651a15..0433b9a4 100644 --- a/installer/OpenSLX/OSSetup/Distro/Any_Clone.pm +++ b/installer/OpenSLX/OSSetup/Distro/Any_Clone.pm @@ -13,14 +13,10 @@ # ----------------------------------------------------------------------------- package OpenSLX::OSSetup::Distro::Any_Clone; -use vars qw($VERSION); -use base qw(OpenSLX::OSSetup::Distro::Base); -$VERSION = 1.01; # API-version . implementation-version - use strict; -use Carp; -use OpenSLX::Basics; -use OpenSLX::OSSetup::Distro::Base 1; +use warnings; + +use base qw(OpenSLX::OSSetup::Distro::Base); ################################################################################ ### implementation diff --git a/installer/OpenSLX/OSSetup/Distro/Base.pm b/installer/OpenSLX/OSSetup/Distro/Base.pm index 769288f1..e0cb5fba 100644 --- a/installer/OpenSLX/OSSetup/Distro/Base.pm +++ b/installer/OpenSLX/OSSetup/Distro/Base.pm @@ -13,11 +13,12 @@ # ----------------------------------------------------------------------------- package OpenSLX::OSSetup::Distro::Base; -use vars qw($VERSION); -$VERSION = 1.01; # API-version . implementation-version - use strict; -use Carp; +use warnings; + +our $VERSION = 1.01; # API-version . implementation-version + +use Carp qw(confess); use File::Basename; use OpenSLX::Basics; diff --git a/installer/OpenSLX/OSSetup/Distro/Debian_3_1.pm b/installer/OpenSLX/OSSetup/Distro/Debian_3_1.pm index be63775b..24ad00a4 100644 --- a/installer/OpenSLX/OSSetup/Distro/Debian_3_1.pm +++ b/installer/OpenSLX/OSSetup/Distro/Debian_3_1.pm @@ -13,14 +13,12 @@ # ----------------------------------------------------------------------------- package OpenSLX::OSSetup::Distro::Debian_3_1; -use vars qw($VERSION); +use strict; +use warnings; + use base qw(OpenSLX::OSSetup::Distro::Base); -$VERSION = 1.01; # API-version . implementation-version -use strict; -use Carp; use OpenSLX::Basics; -use OpenSLX::OSSetup::Distro::Base 1; ################################################################################ ### implementation diff --git a/installer/OpenSLX/OSSetup/Distro/Debian_4_0.pm b/installer/OpenSLX/OSSetup/Distro/Debian_4_0.pm index 825ed542..f4e8a6e4 100644 --- a/installer/OpenSLX/OSSetup/Distro/Debian_4_0.pm +++ b/installer/OpenSLX/OSSetup/Distro/Debian_4_0.pm @@ -13,14 +13,12 @@ # ----------------------------------------------------------------------------- package OpenSLX::OSSetup::Distro::Debian_4_0; -use vars qw($VERSION); +use strict; +use warnings; + use base qw(OpenSLX::OSSetup::Distro::Base); -$VERSION = 1.01; # API-version . implementation-version -use strict; -use Carp; use OpenSLX::Basics; -use OpenSLX::OSSetup::Distro::Base 1; ################################################################################ ### implementation diff --git a/installer/OpenSLX/OSSetup/Distro/Fedora_6.pm b/installer/OpenSLX/OSSetup/Distro/Fedora_6.pm index f2e38868..03f7116a 100644 --- a/installer/OpenSLX/OSSetup/Distro/Fedora_6.pm +++ b/installer/OpenSLX/OSSetup/Distro/Fedora_6.pm @@ -13,14 +13,12 @@ # ----------------------------------------------------------------------------- package OpenSLX::OSSetup::Distro::Fedora_6; -use vars qw($VERSION); +use strict; +use warnings; + use base qw(OpenSLX::OSSetup::Distro::Base); -$VERSION = 1.01; # API-version . implementation-version -use strict; -use Carp; use OpenSLX::Basics; -use OpenSLX::OSSetup::Distro::Base 1; ################################################################################ ### implementation diff --git a/installer/OpenSLX/OSSetup/Distro/Fedora_6_x86_64.pm b/installer/OpenSLX/OSSetup/Distro/Fedora_6_x86_64.pm index 00125f47..46c43e37 100644 --- a/installer/OpenSLX/OSSetup/Distro/Fedora_6_x86_64.pm +++ b/installer/OpenSLX/OSSetup/Distro/Fedora_6_x86_64.pm @@ -13,14 +13,12 @@ # ----------------------------------------------------------------------------- package OpenSLX::OSSetup::Distro::Fedora_6_x86_64; -use vars qw($VERSION); +use strict; +use warnings; + use base qw(OpenSLX::OSSetup::Distro::Base); -$VERSION = 1.01; # API-version . implementation-version -use strict; -use Carp; use OpenSLX::Basics; -use OpenSLX::OSSetup::Distro::Base 1; ################################################################################ ### implementation diff --git a/installer/OpenSLX/OSSetup/Distro/SUSE_10_1.pm b/installer/OpenSLX/OSSetup/Distro/SUSE_10_1.pm index 25ae41bb..819bbb95 100644 --- a/installer/OpenSLX/OSSetup/Distro/SUSE_10_1.pm +++ b/installer/OpenSLX/OSSetup/Distro/SUSE_10_1.pm @@ -13,14 +13,12 @@ # ----------------------------------------------------------------------------- package OpenSLX::OSSetup::Distro::SUSE_10_1; -use vars qw($VERSION); +use strict; +use warnings; + use base qw(OpenSLX::OSSetup::Distro::Base); -$VERSION = 1.01; # API-version . implementation-version -use strict; -use Carp; use OpenSLX::Basics; -use OpenSLX::OSSetup::Distro::Base 1; ################################################################################ ### implementation diff --git a/installer/OpenSLX/OSSetup/Distro/SUSE_10_1_x86_64.pm b/installer/OpenSLX/OSSetup/Distro/SUSE_10_1_x86_64.pm index 983834f8..f80bca32 100644 --- a/installer/OpenSLX/OSSetup/Distro/SUSE_10_1_x86_64.pm +++ b/installer/OpenSLX/OSSetup/Distro/SUSE_10_1_x86_64.pm @@ -13,14 +13,12 @@ # ----------------------------------------------------------------------------- package OpenSLX::OSSetup::Distro::SUSE_10_1_x86_64; -use vars qw($VERSION); +use strict; +use warnings; + use base qw(OpenSLX::OSSetup::Distro::Base); -$VERSION = 1.01; # API-version . implementation-version -use strict; -use Carp; use OpenSLX::Basics; -use OpenSLX::OSSetup::Distro::Base 1; ################################################################################ ### implementation diff --git a/installer/OpenSLX/OSSetup/Distro/SUSE_10_2.pm b/installer/OpenSLX/OSSetup/Distro/SUSE_10_2.pm index 24508911..06fdd322 100644 --- a/installer/OpenSLX/OSSetup/Distro/SUSE_10_2.pm +++ b/installer/OpenSLX/OSSetup/Distro/SUSE_10_2.pm @@ -13,14 +13,12 @@ # ----------------------------------------------------------------------------- package OpenSLX::OSSetup::Distro::SUSE_10_2; -use vars qw($VERSION); +use strict; +use warnings; + use base qw(OpenSLX::OSSetup::Distro::Base); -$VERSION = 1.01; # API-version . implementation-version -use strict; -use Carp; use OpenSLX::Basics; -use OpenSLX::OSSetup::Distro::Base 1; ################################################################################ ### implementation diff --git a/installer/OpenSLX/OSSetup/Distro/SUSE_10_2_x86_64.pm b/installer/OpenSLX/OSSetup/Distro/SUSE_10_2_x86_64.pm index 30268635..e30e0897 100644 --- a/installer/OpenSLX/OSSetup/Distro/SUSE_10_2_x86_64.pm +++ b/installer/OpenSLX/OSSetup/Distro/SUSE_10_2_x86_64.pm @@ -13,14 +13,12 @@ # ----------------------------------------------------------------------------- package OpenSLX::OSSetup::Distro::SUSE_10_2_x86_64; -use vars qw($VERSION); +use strict; +use warnings; + use base qw(OpenSLX::OSSetup::Distro::Base); -$VERSION = 1.01; # API-version . implementation-version -use strict; -use Carp; use OpenSLX::Basics; -use OpenSLX::OSSetup::Distro::Base 1; ################################################################################ ### implementation diff --git a/installer/OpenSLX/OSSetup/Engine.pm b/installer/OpenSLX/OSSetup/Engine.pm index 9b69f2b5..53fce7c7 100644 --- a/installer/OpenSLX/OSSetup/Engine.pm +++ b/installer/OpenSLX/OSSetup/Engine.pm @@ -13,8 +13,11 @@ # ----------------------------------------------------------------------------- package OpenSLX::OSSetup::Engine; -use vars qw(@ISA @EXPORT $VERSION); -$VERSION = 1.01; # API-version . implementation-version +use strict; +use warnings; + +our (@ISA, @EXPORT, $VERSION); +$VERSION = 1.01; # API-version . implementation-version use Exporter; @ISA = qw(Exporter); @@ -23,8 +26,6 @@ use Exporter; %supportedDistros ); -use strict; -use Carp; use File::Basename; use OpenSLX::Basics; use OpenSLX::Utils; @@ -32,40 +33,57 @@ use OpenSLX::Utils; use vars qw(%supportedDistros); %supportedDistros = ( - 'debian-3.1' - => { module => 'Debian_3_1', support => 'clone' }, - 'debian-4.0' - => { module => 'Debian_4_0', support => 'clone' }, - 'fedora-6' - => { module => 'Fedora_6', support => 'clone,install' }, - 'fedora-6_x86_64' - => { module => 'Fedora_6_x86_64', support => 'clone,install' }, - 'gentoo-2005.1' - => { module => 'Gentoo_2005_1', support => 'clone' }, - 'gentoo-2006.1' - => { module => 'Gentoo_2006_1', support => 'clone' }, - 'mandriva-2007.0' - => { module => 'Mandriva_2007_0', support => 'clone' }, - 'suse-9.3' - => { module => 'SUSE_9_3', support => 'clone' }, - 'suse-10.0' - => { module => 'SUSE_10_0', support => 'clone' }, - 'suse-10.0_x86_64' - => { module => 'SUSE_10_0_x86_64', support => 'clone' }, - 'suse-10.1' - => { module => 'SUSE_10_1', support => 'clone,install' }, - 'suse-10.1_x86_64' - => { module => 'SUSE_10_1_x86_64', support => 'clone,install' }, - 'suse-10.2' - => { module => 'SUSE_10_2', support => 'clone,install' }, - 'suse-10.2_x86_64' - => { module => 'SUSE_10_2_x86_64', support => 'clone,install' }, - 'ubuntu-6.06' - => { module => 'Ubuntu_6_06', support => 'clone' }, - 'ubuntu-6.10' - => { module => 'Ubuntu_6_10', support => 'clone' }, - 'ubuntu-7.04' - => { module => 'Ubuntu_7_04', support => 'clone' }, + 'debian-3.1' => { + module => 'Debian_3_1', support => 'clone' + }, + 'debian-4.0' => { + module => 'Debian_4_0', support => 'clone' + }, + 'fedora-6' => { + module => 'Fedora_6', support => 'clone,install' + }, + 'fedora-6_x86_64' => { + module => 'Fedora_6_x86_64', support => 'clone,install' + }, + 'gentoo-2005.1' => { + module => 'Gentoo_2005_1', support => 'clone' + }, + 'gentoo-2006.1' => { + module => 'Gentoo_2006_1', support => 'clone' + }, + 'mandriva-2007.0' => { + module => 'Mandriva_2007_0', support => 'clone' + }, + 'suse-9.3' => { + module => 'SUSE_9_3', support => 'clone' + }, + 'suse-10.0' => { + module => 'SUSE_10_0', support => 'clone' + }, + 'suse-10.0_x86_64' => { + module => 'SUSE_10_0_x86_64', support => 'clone' + }, + 'suse-10.1' => { + module => 'SUSE_10_1', support => 'clone,install' + }, + 'suse-10.1_x86_64' => { + module => 'SUSE_10_1_x86_64', support => 'clone,install' + }, + 'suse-10.2' => { + module => 'SUSE_10_2', support => 'clone,install' + }, + 'suse-10.2_x86_64' => { + module => 'SUSE_10_2_x86_64', support => 'clone,install' + }, + 'ubuntu-6.06' => { + module => 'Ubuntu_6_06', support => 'clone' + }, + 'ubuntu-6.10' => { + module => 'Ubuntu_6_10', support => 'clone' + }, + 'ubuntu-7.04' => { + module => 'Ubuntu_7_04', support => 'clone' + }, ); ################################################################################ @@ -75,8 +93,7 @@ sub new { my $class = shift; - my $self = { - }; + my $self = {}; return bless $self, $class; } @@ -85,10 +102,11 @@ sub DESTROY { my $self = shift; - if ($self->{'local-http-server-master-pid'} == $$) { + my $httpServerPID = $self->{'local-http-server-master-pid'} || '0'; + if ($httpServerPID == $$) { # we are the master process, so we clean up all the servers that we # have started: - while(my ($localURL, $pid) = each %{$self->{'local-http-servers'}}) { + while (my ($localURL, $pid) = each %{$self->{'local-http-servers'}}) { vlog(1, _tr("stopping local HTTP-server for URL '%s'.", $localURL)); kill TERM => $pid; } @@ -97,29 +115,34 @@ sub DESTROY sub initialize { - my $self = shift; + my $self = shift; my $vendorOSName = shift; - my $actionType = shift; + my $actionType = shift; if ($vendorOSName !~ m[^([^\-]+\-[^\-]+)(?:\-(.+))?]) { - die _tr("Given vendor-OS has unknown format, expected '<name>-<release>[-<selection>]'\n"); + die _tr( + "Given vendor-OS has unknown format, expected '<name>-<release>[-<selection>]'\n" + ); } - $self->{'vendor-os-name'} = $vendorOSName; - $self->{'action-type'} = $actionType; my $distroName = $1; my $selectionName = $2 || 'default'; - $self->{'distro-name'} = $distroName; + $self->{'vendor-os-name'} = $vendorOSName; + $self->{'action-type'} = $actionType; + $self->{'distro-name'} = $distroName; $self->{'selection-name'} = $selectionName; + $self->{'clone-source'} = ''; if (!exists $supportedDistros{lc($distroName)}) { print _tr("Sorry, distro '%s' is unsupported.\n", $distroName); print _tr("List of supported distros:\n\t"); - print join("\n\t", sort keys %supportedDistros)."\n"; + print join("\n\t", sort keys %supportedDistros) . "\n"; exit 1; } my $support = $supportedDistros{lc($distroName)}->{support}; if ($actionType eq 'install' && $support !~ m[install]i) { - print _tr("Sorry, distro '%s' can not be installed, only cloned.\n", - $distroName); + print _tr( + "Sorry, distro '%s' can not be installed, only cloned.\n", + $distroName + ); exit 1; } @@ -130,7 +153,8 @@ sub initialize # distro's for which there is no specific distro-module yet # (like for example for Gentoo): $distroClass = "Any_Clone"; - } else { + } + else { $distroClass = $supportedDistros{lc($distroName)}->{module}; } my $distro = instantiateClass("OpenSLX::OSSetup::Distro::$distroClass"); @@ -142,30 +166,39 @@ sub initialize my $sharedDistroInfoDir = "$openslxConfig{'base-path'}/share/distro-info/$distro->{'base-name'}"; if (!-d $sharedDistroInfoDir) { - die _tr("unable to find shared distro-info in '%s'\n", - $sharedDistroInfoDir); + die _tr( + "unable to find shared distro-info in '%s'\n", + $sharedDistroInfoDir + ); } $self->{'shared-distro-info-dir'} = $sharedDistroInfoDir; - my $configDistroInfoDir - = "$openslxConfig{'config-path'}/distro-info/$distro->{'base-name'}"; + my $configDistroInfoDir = + "$openslxConfig{'config-path'}/distro-info/$distro->{'base-name'}"; if (!-d $configDistroInfoDir) { - die _tr("unable to find configurable distro-info in '%s'\n", - $configDistroInfoDir); + die _tr( + "unable to find configurable distro-info in '%s'\n", + $configDistroInfoDir + ); } $self->{'config-distro-info-dir'} = $configDistroInfoDir; $self->readDistroInfo(); } if (!$self->{'action-type'} eq 'install' - && !exists $self->{'distro-info'}->{'selection'}->{$selectionName}) { - die _tr("selection '%s' is unknown to distro '%s'\n", - $selectionName, $distro->{'base-name'}) - ."These selections are available:\n\t" - .join("\n\t", keys %{$self->{'distro-info'}->{'selection'}}) - ."\n"; + && !exists $self->{'distro-info'}->{'selection'}->{$selectionName}) + { + die( + _tr( + "selection '%s' is unknown to distro '%s'\n", + $selectionName, $distro->{'base-name'} + ) + . _tr("These selections are available:\n\t") + . join("\n\t", keys %{$self->{'distro-info'}->{'selection'}}) + . "\n" + ); } - $self->{'vendor-os-path'} + $self->{'vendor-os-path'} = "$openslxConfig{'private-path'}/stage1/$self->{'vendor-os-name'}"; vlog(1, "vendor-OS path is '$self->{'vendor-os-path'}'"); @@ -181,7 +214,8 @@ sub installVendorOS my $installInfoFile = "$self->{'vendor-os-path'}/.openslx-install-info"; if (-e $installInfoFile) { - die _tr("vendor-OS '%s' already exists, giving up!\n", $self->{'vendor-os-path'}); + die _tr("vendor-OS '%s' already exists, giving up!\n", + $self->{'vendor-os-path'}); } $self->createVendorOSPath(); @@ -190,33 +224,43 @@ sub installVendorOS my $baseSystemFile = "$self->{'vendor-os-path'}/.openslx-base-system"; if (-e $baseSystemFile) { vlog(0, _tr("found existing base system, continuing...\n")); - } else { + } + else { # basic setup, stage1a-c: - $self->setupStage1A(); - callInSubprocess( sub { - # some tasks that involve a chrooted environment: - $self->changePersonalityIfNeeded(); - $self->setupStage1B(); - $self->setupStage1C(); - }); - $self->stage1C_cleanupBasicVendorOS(); + $self->setupStage1A(); + callInSubprocess( + sub { + # some tasks that involve a chrooted environment: + $self->changePersonalityIfNeeded(); + $self->setupStage1B(); + $self->setupStage1C(); + } + ); + $self->stage1C_cleanupBasicVendorOS(); + # just touch the file, in order to indicate a basic system: slxsystem("touch $baseSystemFile"); - # just touch the file, in order to indicate a basic system } - callInSubprocess( sub { - # another task that involves a chrooted environment: - $self->changePersonalityIfNeeded(); - $self->setupStage1D(); - }); - # creat the install-info file, in order to indicate a proper installation: - open(INFO, "> $installInfoFile") - or die _tr("unable to create info-file <%s> (%s)\n", $installInfoFile, $!); - print INFO "SLX_META_PACKAGER=$self->{distro}->{'meta-packager-type'}\n"; - close(INFO); + callInSubprocess( + sub { + # another task that involves a chrooted environment: + $self->changePersonalityIfNeeded(); + $self->setupStage1D(); + } + ); + + # create the install-info file, in order to indicate a proper installation: + spitFile($installInfoFile, + "SLX_META_PACKAGER=$self->{distro}->{'meta-packager-type'}\n"); slxsystem("rm $baseSystemFile"); - # no longer needed, we have a full system now - vlog(0, _tr("Vendor-OS '%s' installed succesfully.\n", - $self->{'vendor-os-name'})); + + # no longer needed, we have a full system now + vlog( + 0, + _tr( + "Vendor-OS '%s' installed succesfully.\n", + $self->{'vendor-os-name'} + ) + ); $self->touchVendorOS(); $self->addInstalledVendorOSToConfigDB(); @@ -224,7 +268,7 @@ sub installVendorOS sub cloneVendorOS { - my $self = shift; + my $self = shift; my $source = shift; if (substr($source, -1, 1) ne '/') { @@ -241,9 +285,14 @@ sub cloneVendorOS my $installInfoFile = "$self->{'vendor-os-path'}/.openslx-install-info"; if (-e $installInfoFile) { # oops, given vendor-os has been installed, not cloned, we complain: - die _tr("The vendor-OS '%s' exists but it is no clone, refusing to clobber!\nPlease delete the folder manually, if that's really what you want...\n", - $self->{'vendor-os-path'}); - } elsif (-e $cloneInfoFile) { + croak( + _tr( + "The vendor-OS '%s' exists but it is no clone, refusing to clobber!\nPlease delete the folder manually, if that's really what you want...\n", + $self->{'vendor-os-path'} + ) + ); + } + elsif (-e $cloneInfoFile) { # check if last and current source match: my $cloneInfo = slurpFile($cloneInfoFile); if ($cloneInfo =~ m[^source\s*=\s*(.+?)\s*$]ims) { @@ -252,14 +301,17 @@ sub cloneVendorOS if ($source ne $lastCloneSource) { # protect user from confusing sources (still allowed, though): my $yes = _tr('yes'); - my $no = _tr('no'); - print _tr("Last time this vendor-OS was cloned, it has been cloned from '%s', now you specified a different source: '%s'\nWould you still like to proceed (%s/%s)? ", - $lastCloneSource, $source, $yes, $no); + my $no = _tr('no'); + print _tr( + "Last time this vendor-OS was cloned, it has been cloned from '%s', now you specified a different source: '%s'\nWould you still like to proceed (%s/%s)? ", + $lastCloneSource, $source, $yes, $no + ); my $answer = <STDIN>; - exit 5 unless $answer =~ m[^\s*$yes]i; + exit 5 unless $answer =~ m[^\s*$yes]i; } $isReClone = 1; - } else { + } + else { # Neither the install-info nor the clone-info file exists. This # probably means that the folder has been created by an older # version of the tools. There's not much we can do, we simply @@ -271,18 +323,25 @@ sub cloneVendorOS $self->clone_fetchSource($source); if ($source ne $lastCloneSource) { - open(CLONE_INFO, "> $cloneInfoFile") - or die _tr("unable to create clone-info file '%s', giving up! (%s)\n", - $cloneInfoFile, $!); - print CLONE_INFO "source=$source"; - close CLONE_INFO; + spitFile($cloneInfoFile, "source=$source\n"); } if ($isReClone) { - vlog(0, _tr("Vendor-OS '%s' has been re-cloned succesfully.\n", - $self->{'vendor-os-name'})); - } else { - vlog(0, _tr("Vendor-OS '%s' has been cloned succesfully.\n", - $self->{'vendor-os-name'})); + vlog( + 0, + _tr( + "Vendor-OS '%s' has been re-cloned succesfully.\n", + $self->{'vendor-os-name'} + ) + ); + } + else { + vlog( + 0, + _tr( + "Vendor-OS '%s' has been cloned succesfully.\n", + $self->{'vendor-os-name'} + ) + ); } $self->touchVendorOS(); @@ -295,19 +354,23 @@ sub updateVendorOS if (!-e $self->{'vendor-os-path'}) { die _tr("can't update vendor-OS '%s', since it doesn't exist!\n", - $self->{'vendor-os-path'}); + $self->{'vendor-os-path'}); } $self->startLocalURLServersAsNeeded(); - callInSubprocess( sub { - $self->changePersonalityIfNeeded(); - $self->updateStage1D(); - }); + callInSubprocess( + sub { + $self->changePersonalityIfNeeded(); + $self->updateStage1D(); + } + ); $self->touchVendorOS(); - vlog(0, _tr("Vendor-OS '%s' updated succesfully.\n", - $self->{'vendor-os-name'})); + vlog( + 0, + _tr("Vendor-OS '%s' updated succesfully.\n", $self->{'vendor-os-name'}) + ); } sub startChrootedShellForVendorOS @@ -315,32 +378,53 @@ sub startChrootedShellForVendorOS my $self = shift; if (!-e $self->{'vendor-os-path'}) { - die _tr("can't start chrooted shell for vendor-OS '%s', since it doesn't exist!\n", - $self->{'vendor-os-path'}); + die _tr( + "can't start chrooted shell for vendor-OS '%s', since it doesn't exist!\n", + $self->{'vendor-os-path'} + ); } $self->startLocalURLServersAsNeeded(); - callInSubprocess( sub { - $self->changePersonalityIfNeeded(); - $self->startChrootedShellInStage1D(); - }); + callInSubprocess( + sub { + $self->changePersonalityIfNeeded(); + $self->startChrootedShellInStage1D(); + } + ); $self->touchVendorOS(); - vlog(0, _tr("Chrooted shell for vendor-OS '%s' has been closed.\n", - $self->{'vendor-os-name'})); + vlog( + 0, + _tr( + "Chrooted shell for vendor-OS '%s' has been closed.\n", + $self->{'vendor-os-name'} + ) + ); } sub removeVendorOS { my $self = shift; - vlog(0, _tr("removing vendor-OS folder '%s'...", $self->{'vendor-os-path'})); + vlog( + 0, + _tr("removing vendor-OS folder '%s'...", $self->{'vendor-os-path'}) + ); if (system("rm -r $self->{'vendor-os-path'}")) { - vlog(0, _tr("* unable to remove vendor-OS '%s'!", $self->{'vendor-os-path'})); - } else { - vlog(0, _tr("Vendor-OS '%s' removed succesfully.\n", - $self->{'vendor-os-name'})); + vlog( + 0, + _tr("* unable to remove vendor-OS '%s'!", $self->{'vendor-os-path'}) + ); + } + else { + vlog( + 0, + _tr( + "Vendor-OS '%s' removed succesfully.\n", + $self->{'vendor-os-name'} + ) + ); } $self->removeVendorOSFromConfigDB(); } @@ -350,37 +434,55 @@ sub addInstalledVendorOSToConfigDB my $self = shift; if (!-e $self->{'vendor-os-path'}) { - die _tr("can't import vendor-OS '%s', since it doesn't exist!\n", - $self->{'vendor-os-path'}); + die _tr( + "can't import vendor-OS '%s', since it doesn't exist!\n", + $self->{'vendor-os-path'} + ); } my $openslxDB = instantiateClass("OpenSLX::ConfigDB"); $openslxDB->connect(); + # insert new vendor-os if it doesn't already exist in DB: my $vendorOSName = $self->{'vendor-os-name'}; - my $vendorOS - = $openslxDB->fetchVendorOSByFilter({ 'name' => $vendorOSName }); + my $vendorOS = $openslxDB->fetchVendorOSByFilter({'name' => $vendorOSName}); if (defined $vendorOS) { if ($self->{'clone-source'} ne $vendorOS->{'clone_source'}) { - $openslxDB->changeVendorOS($vendorOS->{id}, { - 'clone_source' => $self->{'clone-source'}, - }); - vlog(0, _tr("Vendor-OS '%s' has been updated in OpenSLX-database.\n", - $vendorOSName)); - } else { - vlog(0, _tr("No need to change vendor-OS '%s' in OpenSLX-database.\n", - $vendorOSName)); + $openslxDB->changeVendorOS( + $vendorOS->{id}, + { 'clone_source' => $self->{'clone-source'} } + ); + vlog( + 0, + _tr( + "Vendor-OS '%s' has been updated in OpenSLX-database.\n", + $vendorOSName + ) + ); } - } else { - my $data = { - 'name' => $vendorOSName, - }; + else { + vlog( + 0, + _tr( + "No need to change vendor-OS '%s' in OpenSLX-database.\n", + $vendorOSName + ) + ); + } + } + else { + my $data = {'name' => $vendorOSName,}; if (length($self->{'clone-source'})) { $data->{'clone_source'} = $self->{'clone-source'}; } my $id = $openslxDB->addVendorOS($data); - vlog(0, _tr("Vendor-OS '%s' has been added to DB (ID=%s).\n", - $vendorOSName, $id)); + vlog( + 0, + _tr( + "Vendor-OS '%s' has been added to DB (ID=%s).\n", + $vendorOSName, $id + ) + ); } $openslxDB->disconnect(); @@ -394,28 +496,39 @@ sub removeVendorOSFromConfigDB $openslxDB->connect(); my $vendorOSName = $self->{'vendor-os-name'}; - my $vendorOS - = $openslxDB->fetchVendorOSByFilter({ 'name' => $vendorOSName }); + my $vendorOS = $openslxDB->fetchVendorOSByFilter({'name' => $vendorOSName}); if (!defined $vendorOS) { - vlog(0, _tr("Vendor-OS '%s' didn't exist in OpenSLX-database.\n", - $vendorOSName)); - } else { + vlog( + 0, + _tr( + "Vendor-OS '%s' didn't exist in OpenSLX-database.\n", + $vendorOSName + ) + ); + } + else { # remove all exports (and systems) using this vendor-OS and then # remove the vendor-OS itself: - my @exports = $openslxDB->fetchExportByFilter( - { 'vendor_os_id' => $vendorOS->{id} } - ); + my @exports = $openslxDB->fetchExportByFilter( + {'vendor_os_id' => $vendorOS->{id}}); foreach my $export (@exports) { my $osExportEngine = instantiateClass("OpenSLX::OSExport::Engine"); $osExportEngine->initializeFromExisting($export->{name}); - vlog(0, _tr("purging export '%s', since it belongs to the vendor-OS being deleted...", - $export->{name})); + vlog( + 0, + _tr( + "purging export '%s', since it belongs to the vendor-OS being deleted...", + $export->{name} + ) + ); $osExportEngine->purgeExport(); } $openslxDB->removeVendorOS($vendorOS->{id}); - vlog(0, _tr("Vendor-OS '%s' has been removed from DB!\n", - $vendorOSName)); + vlog( + 0, + _tr("Vendor-OS '%s' has been removed from DB!\n", $vendorOSName) + ); } $openslxDB->disconnect(); @@ -429,46 +542,51 @@ sub readDistroInfo my $self = shift; vlog(1, "reading configuration info for $self->{'vendor-os-name'}..."); + # merge user-provided configuration distro defaults... my %repository = %{$self->{distro}->{config}->{repository}}; - my %selection = %{$self->{distro}->{config}->{selection}}; - my %excludes = - defined $self->{distro}->{config}->{excludes} + my %selection = %{$self->{distro}->{config}->{selection}}; + my %excludes + = defined $self->{distro}->{config}->{excludes} ? %{$self->{distro}->{config}->{excludes}} : (); - my $package_subdir = $self->{distro}->{config}->{'package-subdir'}; + my $package_subdir = $self->{distro}->{config}->{'package-subdir'}; my $prereq_packages = $self->{distro}->{config}->{'prereq-packages'}; - my $bootstrap_prereq_packages - = $self->{distro}->{config}->{'bootstrap-prereq-packages'}; + my $bootstrap_prereq_packages = + $self->{distro}->{config}->{'bootstrap-prereq-packages'}; my $bootstrap_packages = $self->{distro}->{config}->{'bootstrap-packages'}; - my $metapackager_packages - = $self->{distro}->{config}->{'metapackager-packages'}; + my $metapackager_packages = + $self->{distro}->{config}->{'metapackager-packages'}; my $file = "$self->{'config-distro-info-dir'}/settings"; + if (-e $file) { vlog(2, "reading configuration file $file..."); my $config = slurpFile($file); - if (!eval $config && length($@)) { - die _tr("error in config-file '%s' (%s)", $file, $@)."\n"; + if (!eval { $config } && length($@)) { + die _tr("error in config-file '%s' (%s)", $file, $@) . "\n"; } } + # ...expand selection definitions... foreach my $selKey (keys %selection) { $selection{$selKey} =~ s[<<<([^>]+)>>>][$selection{$1}]eg; } + # ...expand selection definitions... foreach my $exclKey (keys %excludes) { $excludes{$exclKey} =~ s[<<<([^>]+)>>>][$excludes{$1}]eg; } + # ...and store merged config: $self->{'distro-info'} = { - 'package-subdir' => $package_subdir, - 'prereq-packages' => $prereq_packages, + 'package-subdir' => $package_subdir, + 'prereq-packages' => $prereq_packages, 'bootstrap-prereq-packages' => $bootstrap_prereq_packages, - 'bootstrap-packages' => $bootstrap_packages, - 'metapackager-packages' => $metapackager_packages, - 'repository' => \%repository, - 'selection' => \%selection, - 'excludes' => \%excludes, + 'bootstrap-packages' => $bootstrap_packages, + 'metapackager-packages' => $metapackager_packages, + 'repository' => \%repository, + 'selection' => \%selection, + 'excludes' => \%excludes, }; if ($openslxConfig{'verbose-level'} >= 2) { @@ -502,7 +620,7 @@ sub createVendorOSPath if (slxsystem("mkdir -p $self->{'vendor-os-path'}")) { die _tr("unable to create directory '%s', giving up! (%s)\n", - $self->{'vendor-os-path'}, $!); + $self->{'vendor-os-path'}, $!); } } @@ -520,7 +638,7 @@ sub createPackager { my $self = shift; - my $packagerClass + my $packagerClass = "OpenSLX::OSSetup::Packager::$self->{distro}->{'packager-type'}"; my $packager = instantiateClass($packagerClass); $packager->initialize($self); @@ -542,29 +660,30 @@ sub createMetaPackager } } - my $metaPackagerClass - = "OpenSLX::OSSetup::MetaPackager::$metaPackagerType"; - my $metaPackager =instantiateClass($metaPackagerClass); + my $metaPackagerClass = "OpenSLX::OSSetup::MetaPackager::$metaPackagerType"; + my $metaPackager = instantiateClass($metaPackagerClass); $metaPackager->initialize($self); $self->{'meta-packager'} = $metaPackager; } sub sortRepositoryURLs { - my $self = shift; + my $self = shift; my $repoInfo = shift; - if ($repoInfo->{'url'} =~ m[^local:]) { + if (defined $repoInfo->{'url'} && $repoInfo->{'url'} =~ m[^local:]) { # a local URL blocks all the others, in order to avoid causing # (external) network traffic: - my $localURL = $repoInfo->{'url'}; + my $localURL = $repoInfo->{'url'} || ''; $localURL =~ s[^local:][http:]; - return [ $localURL ]; + return [$localURL]; } my %urlInfo; + # specified URL always has highest precedence: - $urlInfo{$repoInfo->{url}} = 0 if defined $repoInfo->{url}; + $urlInfo{$repoInfo->{url}} = 0 if defined $repoInfo->{url}; + # now add all others sorted by "closeness": my $index = 1; foreach my $url (string2Array($repoInfo->{urls})) { @@ -577,11 +696,11 @@ sub sortRepositoryURLs sub downloadBaseFiles { - my $self = shift; + my $self = shift; my $files = shift; - my $pkgSubdir = $self->{'distro-info'}->{'package-subdir'}; - my @URLs = @{$self->{'baseURLs'}}; + my $pkgSubdir = $self->{'distro-info'}->{'package-subdir'}; + my @URLs = @{$self->{'baseURLs'}}; my $maxTryCount = $openslxConfig{'ossetup-max-try-count'}; my @foundFiles; @@ -589,18 +708,20 @@ sub downloadBaseFiles my $tryCount = 0; next unless $fileVariantStr =~ m[\S]; my $foundFile; -try_next_url: + try_next_url: my $url = $URLs[$self->{'baseURL-index'}]; - $url .= "/$pkgSubdir" if length($pkgSubdir); + $url .= "/$pkgSubdir" if length($pkgSubdir); my @contFlags = (); - push @contFlags, '-c' if ($url =~ m[^ftp]); - # continuing is only supported with FTP, but not with HTTP + push @contFlags, '-c' if ($url =~ m[^ftp]); + + # continuing is only supported with FTP, but not with HTTP foreach my $file (split '\s+', $fileVariantStr) { vlog(2, "fetching <$file>..."); if (slxsystem("wget", @contFlags, "$url/$file") == 0) { $foundFile = basename($file); last; - } elsif ($! == 17) { + } + elsif ($! == 17) { my $basefile = basename($file); vlog(2, "removing left-over '$basefile' and trying again..."); unlink $basefile; @@ -609,14 +730,18 @@ try_next_url: if (!defined $foundFile) { if (!$ENV{SLX_NO_MIRRORS} && $tryCount < $maxTryCount) { $tryCount++; - $self->{'baseURL-index'} - = ($self->{'baseURL-index'}+1) % scalar(@URLs); - vlog(0, _tr("switching to mirror '%s'.", - $URLs[$self->{'baseURL-index'}])); + $self->{'baseURL-index'} + = ($self->{'baseURL-index'} + 1) % scalar(@URLs); + vlog( + 0, + _tr( + "switching to mirror '%s'.", + $URLs[$self->{'baseURL-index'}] + ) + ); goto try_next_url; } - die _tr("unable to fetch '%s' from any source!\n", - $fileVariantStr); + die _tr("unable to fetch '%s' from any source!\n", $fileVariantStr); } push @foundFiles, $foundFile; } @@ -630,25 +755,23 @@ sub startLocalURLServersAsNeeded $self->{'local-http-server-master-pid'} = $$; foreach my $repoInfo (values %{$self->{'distro-info'}->{repository}}) { - - next unless $repoInfo->{'url'} =~ m[^local:]; - my $localURL = $repoInfo->{url}; + my $localURL = $repoInfo->{url} || ''; + next unless $localURL =~ m[^local:]; if (!exists $self->{'local-http-servers'}->{$localURL}) { - my $busyboxName - = $self->hostIs64Bit() - ? 'busybox.x86_64' - : 'busybox.i586'; - my $busybox = "$openslxConfig{'base-path'}/share/busybox/$busyboxName"; + my $busyboxName = + $self->hostIs64Bit() + ? 'busybox.x86_64' + : 'busybox.i586'; + my $busybox = + "$openslxConfig{'base-path'}/share/busybox/$busyboxName"; my $port = 5080; if ($localURL =~ m[:(\d+)/]) { $port = $1; } - my $pid = executeInSubprocess( - $busybox, "httpd", - '-p', $port, - '-h', '/', - '-f' - ); + my $pid + = executeInSubprocess( + $busybox, "httpd", '-p', $port, '-h', '/', '-f' + ); vlog(1, _tr("started local HTTP-server for URL '%s'.", $localURL)); $self->{'local-http-servers'}->{$localURL} = $pid; } @@ -662,16 +785,16 @@ sub setupStage1A vlog(1, "setting up stage1a for $self->{'vendor-os-name'}..."); # specify individual paths for the respective substages: - $self->{stage1aDir} = "$self->{'vendor-os-path'}/stage1a"; + $self->{stage1aDir} = "$self->{'vendor-os-path'}/stage1a"; $self->{stage1bSubdir} = 'slxbootstrap'; $self->{stage1cSubdir} = 'slxfinal'; # we create *all* of the above folders by creating stage1cDir: - my $stage1cDir + my $stage1cDir = "$self->{'stage1aDir'}/$self->{'stage1bSubdir'}/$self->{'stage1cSubdir'}"; if (slxsystem("mkdir -p $stage1cDir")) { die _tr("unable to create directory '%s', giving up! (%s)\n", - $stage1cDir, $!); + $stage1cDir, $!); } $self->stage1A_createBusyboxEnvironment(); @@ -686,22 +809,22 @@ sub stage1A_createBusyboxEnvironment # copy busybox and all required binaries into stage1a-dir: vlog(1, "creating busybox-environment..."); - my $busyboxName - = $self->hostIs64Bit() - ? 'busybox.x86_64' - : 'busybox.i586'; - copyFile("$openslxConfig{'base-path'}/share/busybox/$busyboxName", - "$self->{stage1aDir}/bin", 'busybox'); + my $busyboxName = $self->hostIs64Bit() ? 'busybox.x86_64' : 'busybox.i586'; + copyFile( + "$openslxConfig{'base-path'}/share/busybox/$busyboxName", + "$self->{stage1aDir}/bin", 'busybox' + ); # determine all required libraries and copy those, too: vlog(1, _tr("calling slxldd for $busyboxName")); - my $slxlddCmd + my $slxlddCmd = "slxldd $openslxConfig{'base-path'}/share/busybox/$busyboxName"; vlog(2, "executing: $slxlddCmd"); my $requiredLibsStr = `$slxlddCmd`; if ($?) { - die _tr("slxldd couldn't determine the libs required by busybox! (%s)", - $?); + die _tr( + "slxldd couldn't determine the libs required by busybox! (%s)", $? + ); } chomp $requiredLibsStr; vlog(2, "slxldd results:\n$requiredLibsStr"); @@ -718,16 +841,18 @@ sub stage1A_createBusyboxEnvironment } # create all needed links to busybox: - my $links + my $links = slurpFile("$openslxConfig{'base-path'}/share/busybox/busybox.links"); foreach my $linkTarget (split "\n", $links) { linkFile('/bin/busybox', "$self->{stage1aDir}/$linkTarget"); } - if ($self->hostIs64Bit() && !-e "$self->{stage1aDir}/lib64") { - linkFile('/lib', "$self->{stage1aDir}/lib64"); - } - if ($self->hostIs64Bit() && !-e "$self->{stage1aDir}/usr/lib64") { - linkFile('/usr/lib', "$self->{stage1aDir}/usr/lib64"); + if ($self->hostIs64Bit()) { + if (!-e "$self->{stage1aDir}/lib64") { + linkFile('/lib', "$self->{stage1aDir}/lib64"); + } + if (!-e "$self->{stage1aDir}/usr/lib64") { + linkFile('/usr/lib', "$self->{stage1aDir}/usr/lib64"); + } } $self->stage1A_setupResolver($libcFolder); @@ -735,7 +860,7 @@ sub stage1A_createBusyboxEnvironment sub stage1A_setupResolver { - my $self = shift; + my $self = shift; my $libcFolder = shift; if (!defined $libcFolder) { @@ -743,11 +868,11 @@ sub stage1A_setupResolver $libcFolder = '/lib'; } - copyFile('/etc/resolv.conf', "$self->{stage1aDir}/etc"); - copyFile("$libcFolder/libresolv*", "$self->{stage1aDir}$libcFolder"); + copyFile('/etc/resolv.conf', "$self->{stage1aDir}/etc"); + copyFile("$libcFolder/libresolv*", "$self->{stage1aDir}$libcFolder"); copyFile("$libcFolder/libnss_dns*", "$self->{stage1aDir}$libcFolder"); - my $stage1cDir + my $stage1cDir = "$self->{'stage1aDir'}/$self->{'stage1bSubdir'}/$self->{'stage1cSubdir'}"; copyFile('/etc/resolv.conf', "$stage1cDir/etc"); } @@ -759,15 +884,17 @@ sub stage1A_copyPrerequiredFiles return unless -d "$self->{'shared-distro-info-dir'}/prereqfiles"; vlog(2, "copying folder with pre-required files..."); - my $stage1cDir + my $stage1cDir = "$self->{'stage1aDir'}/$self->{'stage1bSubdir'}/$self->{'stage1cSubdir'}"; my $cmd = qq[ tar -cp -C $self->{'shared-distro-info-dir'}/prereqfiles . \\ | tar -xp -C $stage1cDir ]; if (slxsystem($cmd)) { - die _tr("unable to copy folder with pre-required files to folder '%s' (%s)\n", - $stage1cDir, $!); + die _tr( + "unable to copy folder with pre-required files to folder '%s' (%s)\n", + $stage1cDir, $! + ); } $self->{distro}->fixPrerequiredFiles($stage1cDir); } @@ -777,10 +904,9 @@ sub stage1A_copyTrustedPackageKeys my $self = shift; vlog(2, "copying folder with trusted package keys..."); - my $stage1bDir - = "$self->{'stage1aDir'}/$self->{'stage1bSubdir'}"; + my $stage1bDir = "$self->{'stage1aDir'}/$self->{'stage1bSubdir'}"; foreach my $folder ( - $self->{'shared-distro-info-dir'}, $self->{'config-distro-info-dir'}, + $self->{'shared-distro-info-dir'}, $self->{'config-distro-info-dir'} ) { next unless -d "$folder/trusted-package-keys"; my $cmd = qq[ @@ -788,14 +914,15 @@ sub stage1A_copyTrustedPackageKeys | tar -xp -C $stage1bDir ]; if (slxsystem($cmd)) { - die _tr("unable to copy folder with trusted package keys to folder '%s' (%s)\n", - "$stage1bDir/trusted-package-keys", $!); + die _tr( + "unable to copy folder with trusted package keys to folder '%s' (%s)\n", + "$stage1bDir/trusted-package-keys", $! + ); } slxsystem("chmod 444 $stage1bDir/trusted-package-keys/*"); # install ultimately trusted keys (from distributor): - my $stage1cDir - = "$stage1bDir/$self->{'stage1cSubdir'}"; + my $stage1cDir = "$stage1bDir/$self->{'stage1cSubdir'}"; my $keyDir = "$self->{'shared-distro-info-dir'}/trusted-package-keys"; if (-e "$keyDir/pubring.gpg") { copyFile("$keyDir/pubring.gpg", "$stage1cDir/usr/lib/rpm/gnupg"); @@ -808,23 +935,26 @@ sub stage1A_createRequiredFiles my $self = shift; vlog(2, "creating required files..."); + # fake all files required by stage1b (by creating them empty): - my $stage1bDir - = "$self->{'stage1aDir'}/$self->{'stage1bSubdir'}"; + my $stage1bDir = "$self->{'stage1aDir'}/$self->{'stage1bSubdir'}"; foreach my $fake (@{$self->{distro}->{'stage1b-faked-files'}}) { fakeFile("$stage1bDir/$fake"); } # fake all files required by stage1c (by creating them empty): - my $stage1cDir - = "$stage1bDir/$self->{'stage1cSubdir'}"; + my $stage1cDir = "$stage1bDir/$self->{'stage1cSubdir'}"; foreach my $fake (@{$self->{distro}->{'stage1c-faked-files'}}) { fakeFile("$stage1cDir/$fake"); } mkdir "$stage1cDir/dev"; - if (!-e "$stage1cDir/dev/null" && slxsystem("mknod $stage1cDir/dev/null c 1 3")) { - die _tr("unable to create node '%s' (%s)\n", "$stage1cDir/dev/null", $!); + if (!-e "$stage1cDir/dev/null" + && slxsystem("mknod $stage1cDir/dev/null c 1 3")) + { + die _tr( + "unable to create node '%s' (%s)\n", "$stage1cDir/dev/null", $! + ); } } @@ -844,11 +974,15 @@ sub stage1B_chrootAndBootstrap # chdir into slxbootstrap, as we want to drop packages into there: chdir "/$self->{stage1bSubdir}" - or die _tr("unable to chdir into '%s' (%s)\n", "/$self->{stage1bSubdir}", $!); + or die _tr( + "unable to chdir into '%s' (%s)\n", "/$self->{stage1bSubdir}", $! + ); # fetch prerequired packages: - $self->{'baseURLs'} - = $self->sortRepositoryURLs($self->{'distro-info'}->{repository}->{base}); + $self->{'baseURLs'} + = $self->sortRepositoryURLs( + $self->{'distro-info'}->{repository}->{base} + ); $self->{'baseURL-index'} = 0; my @pkgs = string2Array($self->{'distro-info'}->{'prereq-packages'}); my @prereqPkgs = $self->downloadBaseFiles(\@pkgs); @@ -859,14 +993,16 @@ sub stage1B_chrootAndBootstrap $self->{'bootstrap-prereq-packages'} = \@bootstrapPrereqPkgs; @pkgs = string2Array($self->{'distro-info'}->{'bootstrap-packages'}); - push @pkgs, string2Array( - $self->{'distro-info'}->{'metapackager-packages'}->{ - $self->{distro}->{'meta-packager-type'} - } + push( + @pkgs, + string2Array( + $self->{'distro-info'}->{'metapackager-packages'} + ->{$self->{distro}->{'meta-packager-type'}} + ) ); my @bootstrapPkgs = $self->downloadBaseFiles(\@pkgs); my @allPkgs = (@prereqPkgs, @bootstrapPrereqPkgs, @bootstrapPkgs); - $self->{'bootstrap-packages'} = \@allPkgs; + $self->{'bootstrap-packages'} = \@allPkgs; } sub setupStage1C @@ -885,20 +1021,23 @@ sub stage1C_chrootAndInstallBasicVendorOS chrootInto($stage1bDir); my $stage1cDir = "/$self->{stage1cSubdir}"; + # install all prerequired bootstrap packages $self->{packager}->installPrerequiredPackages( - $self->{'bootstrap-prereq-packages'}, $stage1cDir + $self->{'bootstrap-prereq-packages'}, + $stage1cDir ); # import any additional trusted package keys to rpm-DB: my $keyDir = "/trusted-package-keys"; - opendir(KEYDIR, $keyDir) + my $keyDirDH; + opendir($keyDirDH, $keyDir) or die _tr("unable to opendir '%s' (%s)\n", $keyDir, $!); - my @keyFiles + my @keyFiles = map { "$keyDir/$_" } - grep { $_ !~ m[^(\.\.?|pubring.gpg)$] } - readdir(KEYDIR); - closedir(KEYDIR); + grep { $_ !~ m[^(\.\.?|pubring.gpg)$] } + readdir($keyDirDH); + closedir($keyDirDH); $self->{packager}->importTrustedPackageKeys(\@keyFiles, $stage1cDir); # install all other bootstrap packages @@ -911,15 +1050,19 @@ sub stage1C_cleanupBasicVendorOS { my $self = shift; - my $stage1cDir + my $stage1cDir = "$self->{'stage1aDir'}/$self->{'stage1bSubdir'}/$self->{'stage1cSubdir'}"; if (slxsystem("mv $stage1cDir/* $self->{'vendor-os-path'}/")) { - die _tr("unable to move final setup to '%s' (%s)\n", - $self->{'vendor-os-path'}, $!); + die _tr( + "unable to move final setup to '%s' (%s)\n", + $self->{'vendor-os-path'}, $! + ); } if (slxsystem("rm -rf $self->{stage1aDir}")) { - die _tr("unable to remove temporary folder '%s' (%s)\n", - $self->{stage1aDir}, $!); + die _tr( + "unable to remove temporary folder '%s' (%s)\n", + $self->{stage1aDir}, $! + ); } } @@ -960,28 +1103,29 @@ sub startChrootedShellInStage1D $self->{'meta-packager'}->startSession(); slxsystem('sh'); - # hangs until user exits manually + + # hangs until user exits manually $self->{'distro'}->updateDistroConfig(); $self->{'meta-packager'}->finishSession(); } -sub stage1D_setupPackageSources() +sub stage1D_setupPackageSources { my $self = shift; vlog(1, "setting up package sources for meta packager..."); my $selectionName = $self->{'selection-name'}; - my $pkgExcludes = $self->{'distro-info'}->{excludes}->{$selectionName}; - my $excludeList = join ' ', string2Array($pkgExcludes); + my $pkgExcludes = $self->{'distro-info'}->{excludes}->{$selectionName}; + my $excludeList = join ' ', string2Array($pkgExcludes); $self->{'meta-packager'}->initPackageSources(); my ($rk, $repo); - while(($rk, $repo) = each %{$self->{'distro-info'}->{repository}}) { + while (($rk, $repo) = each %{$self->{'distro-info'}->{repository}}) { vlog(2, "setting up package source $rk..."); $self->{'meta-packager'}->setupPackageSource($rk, $repo, $excludeList); } } -sub stage1D_updateBasicVendorOS() +sub stage1D_updateBasicVendorOS { my $self = shift; @@ -999,22 +1143,27 @@ sub stage1D_installPackageSelection my $selectionName = $self->{'selection-name'}; vlog(1, "installing package selection <$selectionName>..."); - my $pkgSelection = $self->{'distro-info'}->{selection}->{$selectionName}; - my @pkgs = string2Array($pkgSelection); + my $pkgSelection = $self->{'distro-info'}->{selection}->{$selectionName}; + my @pkgs = string2Array($pkgSelection); my @installedPkgs = $self->{'packager'}->getInstalledPackages(); - @pkgs - = grep { - my $pkg = $_; - if (grep { $_ eq $pkg; } @installedPkgs) { - vlog(1, "package '$pkg' filtered, it is already installed."); - 0; - } else { - 1; - } - } @pkgs; - vlog(0, _tr("No packages listed for selection '%s', nothing to do.", - $selectionName)); - vlog(1, "installing these packages:\n".join("\n\t", @pkgs)); + @pkgs = grep { + my $pkg = $_; + if (grep { $_ eq $pkg; } @installedPkgs) { + vlog(1, "package '$pkg' filtered, it is already installed."); + 0; + } + else { + 1; + } + } @pkgs; + vlog( + 0, + _tr( + "No packages listed for selection '%s', nothing to do.", + $selectionName + ) + ); + vlog(1, "installing these packages:\n" . join("\n\t", @pkgs)); $self->{'meta-packager'}->startSession(); if (scalar(@pkgs) > 0) { $self->{'meta-packager'}->installSelection(join " ", @pkgs); @@ -1025,54 +1174,69 @@ sub stage1D_installPackageSelection sub clone_fetchSource { - my $self = shift; + my $self = shift; my $source = shift; - vlog(0, _tr("Cloning vendor-OS from '%s' to '%s'...\n", $source, - $self->{'vendor-os-path'})); + vlog( + 0, + _tr( + "Cloning vendor-OS from '%s' to '%s'...\n", $source, + $self->{'vendor-os-path'} + ) + ); my $excludeIncludeList = $self->clone_determineIncludeExcludeList(); vlog(1, "using exclude-include-filter:\n$excludeIncludeList\n"); - my $rsyncCmd + my $rsyncCmd = "rsync -av --delete --exclude-from=- $source $self->{'vendor-os-path'}"; vlog(2, "executing: $rsyncCmd\n"); - open(RSYNC, "| $rsyncCmd") - or die _tr("unable to start rsync for source '%s', giving up! (%s)\n", - $source, $!); - print RSYNC $excludeIncludeList; - if (!close(RSYNC)) { - die _tr("unable to clone from source '%s', giving up! (%s)\n", - $source, $!); - } + my $rsyncFH; + open($rsyncFH, '|-', $rsyncCmd) + or croak( + _tr( + "unable to start rsync for source '%s', giving up! (%s)\n", + $source, $! + ) + ); + print $rsyncFH $excludeIncludeList; + close($rsyncFH) + or croak _tr( + "unable to clone from source '%s', giving up! (%s)\n", $source, $! + ); } sub clone_determineIncludeExcludeList { my $self = shift; - my $localFilterFile + my $localFilterFile = "$openslxConfig{'config-path'}/distro-info/clone-filter"; - my $includeExcludeList = slurpFile($localFilterFile, 1); + my $includeExcludeList + = slurpFile($localFilterFile, { failIfMissing => 0 }); $includeExcludeList .= $self->{distro}->{'clone-filter'}; $includeExcludeList =~ s[^\s+][]igms; - # remove any leading whitespace, as rsync doesn't like it + + # remove any leading whitespace, as rsync doesn't like it return $includeExcludeList; } ################################################################################ ### utility methods ################################################################################ -sub changePersonalityIfNeeded { +sub changePersonalityIfNeeded +{ my $self = shift; my $distroName = $self->{distro}->{'base-name'}; if ($self->hostIs64Bit() && $distroName !~ m[_64]) { # trying to handle a 32-bit vendor-OS on a 64-bit machine, so we change # the personality accordingly (from 64-bit to 32-bit): - require 'syscall.ph' - or die _tr("unable to load '%s'\n", 'syscall.ph'); - require 'linux/personality.ph' - or die _tr("unable to load '%s'\n", 'linux/personality.ph'); - no strict; + my $syscallPH = 'syscall.ph'; + eval { require $syscallPH } + or die _tr("unable to load '%s'\n", $syscallPH); + my $personalityPH = 'linux/personality.ph'; + eval { require $personalityPH } + or die _tr("unable to load '%s'\n", $personalityPH); + syscall &SYS_personality, PER_LINUX32(); } } @@ -1081,7 +1245,7 @@ sub hostIs64Bit { my $self = shift; - $self->{arch} = `uname -m` unless defined $self->{arch}; + $self->{arch} = `uname -m` unless defined $self->{arch}; return ($self->{arch} =~ m[64]); } @@ -1090,13 +1254,16 @@ sub hostIs64Bit ################################################################################ sub string2Array { - my $str = shift; + my $string = shift || ''; + + my @lines = split m[\n], $string; + for my $line (@lines) { + # remove leading and trailing whitespace: + $line =~ s{^\s*(.*?)\s*$}{$1}; + } - return - grep { length($_) > 0 && $_ !~ m[^\s*#]; } - # drop empty lines and comments - map { $_ =~ s[^\s*(.*?)\s*$][$1]; $_ } - split "\n", $str; + # drop empty lines and comments: + return grep { length($_) > 0 && $_ !~ m[^\s*#]; } @lines; } sub chrootInto @@ -1106,6 +1273,7 @@ sub chrootInto vlog(2, "chrooting into $osDir..."); chdir $osDir or die _tr("unable to chdir into '%s' (%s)\n", $osDir, $!); + # ...do chroot chroot "." or die _tr("unable to chroot into '%s' (%s)\n", $osDir, $!); @@ -1127,3 +1295,4 @@ OpenSLX::OSSetup::Engine - driver engine for OSSetup API ... =cut + diff --git a/installer/OpenSLX/OSSetup/MetaPackager/Base.pm b/installer/OpenSLX/OSSetup/MetaPackager/Base.pm index 218dd131..cfcb013c 100644 --- a/installer/OpenSLX/OSSetup/MetaPackager/Base.pm +++ b/installer/OpenSLX/OSSetup/MetaPackager/Base.pm @@ -13,12 +13,12 @@ # ----------------------------------------------------------------------------- package OpenSLX::OSSetup::MetaPackager::Base; -use vars qw($VERSION); -$VERSION = 1.01; # API-version . implementation-version - use strict; +use warnings; + +our $VERSION = 1.01; # API-version . implementation-version -use Carp; +use Carp qw(confess); use OpenSLX::Basics; ################################################################################ diff --git a/installer/OpenSLX/OSSetup/MetaPackager/smart.pm b/installer/OpenSLX/OSSetup/MetaPackager/smart.pm index bef44ddc..6e411a89 100644 --- a/installer/OpenSLX/OSSetup/MetaPackager/smart.pm +++ b/installer/OpenSLX/OSSetup/MetaPackager/smart.pm @@ -13,14 +13,13 @@ # ----------------------------------------------------------------------------- package OpenSLX::OSSetup::MetaPackager::smart; -use vars qw($VERSION); +use strict; +use warnings; + use base qw(OpenSLX::OSSetup::MetaPackager::Base); -$VERSION = 1.01; # API-version . implementation-version -use strict; -use Carp; use OpenSLX::Basics; -use OpenSLX::OSSetup::MetaPackager::Base 1; +use OpenSLX::Utils; ################################################################################ ### implementation @@ -61,7 +60,7 @@ sub setupPackageSource my $repoInfo = shift; my $excludeList = shift; - my $repoSubdir; + my $repoSubdir = ''; if (length($repoInfo->{'repo-subdir'})) { $repoSubdir = "/$repoInfo->{'repo-subdir'}"; } @@ -78,8 +77,13 @@ sub setupPackageSource foreach my $mirrorURL (@$repoURLs) { $mirrorDescr .= " --add $baseURL$repoSubdir $mirrorURL$repoSubdir"; } - if (slxsystem("smart mirror $mirrorDescr")) { - die _tr("unable to add mirrors for channel '%s' (%s)\n", $repoName, $!); + if (defined $mirrorDescr) { + if (slxsystem("smart mirror $mirrorDescr")) { + die _tr( + "unable to add mirrors for channel '%s' (%s)\n", + $repoName, $! + ); + } } } } diff --git a/installer/OpenSLX/OSSetup/MetaPackager/yum.pm b/installer/OpenSLX/OSSetup/MetaPackager/yum.pm index ebd7effd..a1d2fa42 100644 --- a/installer/OpenSLX/OSSetup/MetaPackager/yum.pm +++ b/installer/OpenSLX/OSSetup/MetaPackager/yum.pm @@ -13,14 +13,13 @@ # ----------------------------------------------------------------------------- package OpenSLX::OSSetup::MetaPackager::yum; -use vars qw($VERSION); +use strict; +use warnings; + use base qw(OpenSLX::OSSetup::MetaPackager::Base); -$VERSION = 1.01; # API-version . implementation-version -use strict; -use Carp; use OpenSLX::Basics; -use OpenSLX::OSSetup::MetaPackager::Base 1; +use OpenSLX::Utils; ################################################################################ ### implementation @@ -73,11 +72,7 @@ sub setupPackageSource } } my $repoFile = "/etc/yum.repos.d/$repoName.repo"; - open(REPO, "> $repoFile") - or die _tr("unable to create repo-file <%s> (%s)\n", $repoFile, $!); - print REPO $repoDescr; - print REPO "\nexclude=$excludeList\n"; - close(REPO); + spitFile($repoFile, "$repoDescr\nexclude=$excludeList\n"); } sub installSelection diff --git a/installer/OpenSLX/OSSetup/Packager/Base.pm b/installer/OpenSLX/OSSetup/Packager/Base.pm index 053b56d9..4ca24621 100644 --- a/installer/OpenSLX/OSSetup/Packager/Base.pm +++ b/installer/OpenSLX/OSSetup/Packager/Base.pm @@ -13,11 +13,12 @@ # ----------------------------------------------------------------------------- package OpenSLX::OSSetup::Packager::Base; -use vars qw($VERSION); -$VERSION = 1.01; # API-version . implementation-version - use strict; -use Carp; +use warnings; + +our $VERSION = 1.01; # API-version . implementation-version + +use Carp qw(confess); ################################################################################ ### interface methods diff --git a/installer/OpenSLX/OSSetup/Packager/rpm.pm b/installer/OpenSLX/OSSetup/Packager/rpm.pm index a792cffe..234ab404 100644 --- a/installer/OpenSLX/OSSetup/Packager/rpm.pm +++ b/installer/OpenSLX/OSSetup/Packager/rpm.pm @@ -13,14 +13,12 @@ # ----------------------------------------------------------------------------- package OpenSLX::OSSetup::Packager::rpm; -use vars qw($VERSION); +use strict; +use warnings; + use base qw(OpenSLX::OSSetup::Packager::Base); -$VERSION = 1.01; # API-version . implementation-version -use strict; -use Carp; use OpenSLX::Basics; -use OpenSLX::OSSetup::Packager::Base 1; ################################################################################ ### implementation diff --git a/installer/slxos-export b/installer/slxos-export index 19ec3d5b..bdebd9f3 100755 --- a/installer/slxos-export +++ b/installer/slxos-export @@ -11,6 +11,7 @@ # General information about OpenSLX can be found at http://openslx.org/ # ----------------------------------------------------------------------------- use strict; +use warnings; my $abstract = q[ slxos-export @@ -61,9 +62,10 @@ if ($action =~ m[^list-ex]i) { print _tr("List of exported vendor-OSes:\n"); foreach my $type (sort keys %supportedExportFileSystems) { # list all image files, followed by the block devices using it: - my @files = map { - s[^.+/][]; - $_ + my @files = map { + my $image = $_; + $image =~ s[^.+/][]; + $image; } sort <$openslxConfig{'public-path'}/export/$type/*>; my %imageFiles; foreach my $file (@files) { @@ -95,13 +97,14 @@ if ($action =~ m[^list-ex]i) { ); } } elsif ($action =~ m[^list-in]i) { - my @files = <$openslxConfig{'private-path'}/stage1/*>; + my @files = glob("$openslxConfig{'private-path'}/stage1/*"); print _tr("List of installed vendor-OSes:\n"); print join( '', map { - s[^.+/][]; - "\t$_\n"; + my $vendorOS = $_; + $vendorOS =~ s[^.+/][]; + "\t$vendorOS\n"; } sort @files ); diff --git a/installer/slxos-setup b/installer/slxos-setup index 381de5b3..1ba15527 100755 --- a/installer/slxos-setup +++ b/installer/slxos-setup @@ -11,6 +11,7 @@ # General information about OpenSLX can be found at http://openslx.org/ # ----------------------------------------------------------------------------- use strict; +use warnings; my $abstract = q[ slxos-setup @@ -155,8 +156,9 @@ if ($action =~ m[^import]i) { } elsif ($action =~ m[^list-in]i) { print _tr("List of installed vendor-OSes:\n"); print join('', map { - s[^.+/][]; - "\t$_\n"; + my $vendorOS = $_; + $vendorOS =~ s[^.+/][]; + "\t$vendorOS\n"; } sort <$openslxConfig{'private-path'}/stage1/*>); } else { diff --git a/lib/OpenSLX/Basics.pm b/lib/OpenSLX/Basics.pm index e675ee52..1624727c 100644 --- a/lib/OpenSLX/Basics.pm +++ b/lib/OpenSLX/Basics.pm @@ -14,7 +14,9 @@ package OpenSLX::Basics; use strict; -use vars qw(@ISA @EXPORT $VERSION); +use warnings; + +our (@ISA, @EXPORT, $VERSION); use Exporter; $VERSION = 1.01; @@ -23,31 +25,32 @@ $VERSION = 1.01; @EXPORT = qw( &openslxInit %openslxConfig %cmdlineConfig &_tr &trInit - &warn &die + &warn &die &croak &carp &confess &cluck &callInSubprocess &executeInSubprocess &slxsystem &vlog &instantiateClass &addCleanupFunction &removeCleanupFunction ); -use vars qw(%openslxConfig %cmdlineConfig %openslxPath); -use subs qw(die); +our (%openslxConfig, %cmdlineConfig, %openslxPath); + +use subs qw(die warn); ################################################################################ ### Module implementation ################################################################################ -use Carp; -use - Carp::Heavy; # use it here to have it loaded immediately, not at - # the time when carp() is being invoked (which might - # be at a point in time where the script executes in - # a chrooted environment, such that the module can't - # be loaded anymore). +require Carp; # do not import anything as we are going to overload carp + # and croak! +use Carp::Heavy; # use it here to have it loaded immediately, not at + # the time when carp() is being invoked (which might + # be at a point in time where the script executes in + # a chrooted environment, such that the module can't + # be loaded anymore). use FindBin; use Getopt::Long; use POSIX qw(locale_h); -my %translations; +my $translations; # this hash will hold the active openslx configuration, # the initial content is based on environment variables or default values. @@ -80,6 +83,7 @@ chomp($openslxConfig{'locale-charmap'}); # specification of cmdline arguments that are shared by all openslx-scripts: my %openslxCmdlineArgs = ( + # name of database, defaults to 'openslx' 'db-name=s' => \$cmdlineConfig{'db-name'}, @@ -124,6 +128,8 @@ my %cleanupFunctions; # filehandle used for logging: my $openslxLog = *STDERR; +$Carp::CarpLevel = 3; + # ------------------------------------------------------------------------------ sub vlog { @@ -147,14 +153,16 @@ sub openslxInit my $configPath = $cmdlineConfig{'config-path'} || $openslxConfig{'config-path'}; my $sharePath = "$openslxConfig{'base-path'}/share"; + my $configFH; + my $verboseLevel = $cmdlineConfig{'verbose-level'} || 0; foreach my $f ("$sharePath/settings.default", "$configPath/settings", "$ENV{HOME}/.openslx/settings") { - next unless open(CONFIG, "<$f"); - if ($cmdlineConfig{'verbose-level'} >= 2) { + next unless open($configFH, '<', $f); + if ($verboseLevel >= 2) { vlog(0, "reading config-file $f..."); } - while (<CONFIG>) { + while (<$configFH>) { chomp; s/#.*//; s/^\s+//; @@ -176,7 +184,7 @@ sub openslxInit $key =~ tr/[A-Z]_/[a-z]-/; $openslxConfig{$key} = $value; } - close CONFIG; + close $configFH; } # push any cmdline argument into our config hash, possibly overriding any @@ -186,10 +194,14 @@ sub openslxInit $openslxConfig{$key} = $val; } - if (defined $openslxConfig{'logfile'} - && open(LOG, ">>$openslxConfig{'logfile'}")) - { - $openslxLog = *LOG; + if (defined $openslxConfig{'logfile'}) { + open($openslxLog, '>>', $openslxConfig{'logfile'}) + or croak( + _tr( + "unable to append to logfile '%s'! (%s)", + $openslxConfig{'logfile'}, $! + ) + ); } if ($openslxConfig{'verbose-level'} >= 2) { foreach my $k (sort keys %openslxConfig) { @@ -206,8 +218,9 @@ sub openslxInit # ------------------------------------------------------------------------------ sub trInit { + # set the specified locale... - setlocale('LC_ALL', $openslxConfig{'locale'}); + setlocale(LC_ALL, $openslxConfig{'locale'}); # ...and activate automatic charset conversion on all I/O streams: binmode(STDIN, ":encoding($openslxConfig{'locale-charmap'})"); @@ -223,6 +236,7 @@ sub trInit } if (lc($locale) ne 'posix') { + # parse locale and canonicalize it (e.g. to 'de_DE') and generate # two filenames from it (language+country and language only): if ($locale !~ m{^\s*([^_]+)(?:_(\w+))?}) { @@ -238,17 +252,13 @@ sub trInit # specific one [language+country]): my $loadedTranslationModule; foreach my $trName (@locales) { - my $trModule = "OpenSLX::Translations::$trName"; - if (eval "require $trModule") { - # Access OpenSLX::Translations::<locale>::translations - # via a symbolic reference... - no strict 'refs'; - my $translationsRef = \%{"${trModule}::translations"}; - - # ...and copy the available translations into our hash: - foreach my $k (keys %{$translationsRef}) { - $translations{$k} = $translationsRef->{$k}; - } + vlog(2, "trying to load translation module $trName..."); + my $trModule = "OpenSLX/Translations/$trName.pm"; + my $trModuleSpec = "OpenSLX::Translations::$trName"; + if (eval { require $trModule } ) { + # copy the translations available in the given locale into our + # hash: + $translations = $trModuleSpec->getAllTranslations(); $loadedTranslationModule = $trModule; vlog( 1, @@ -276,7 +286,10 @@ sub _tr $trKey =~ s[\n][\\n]g; $trKey =~ s[\t][\\t]g; - my $formatStr = $translations{$trKey}; + my $formatStr; + if (defined $translations) { + $formatStr = $translations->{$trKey}; + } if (!defined $formatStr) { $formatStr = $trOrig; } @@ -290,6 +303,7 @@ sub callInSubprocess my $pid = fork(); if (!$pid) { + # child... # ...execute the given function and exit: &$childFunc(); @@ -315,6 +329,7 @@ sub executeInSubprocess my $pid = fork(); if (!$pid) { + # child... # ...exec the given cmdline: exec(@cmdlineArgs); @@ -357,6 +372,7 @@ sub slxsystem vlog(2, _tr("executing: %s", join ' ', @_)); my $res = system(@_); if ($res > 0) { + # check if child got killed, if so we stop, too (unless the signal is # SIGPIPE, which we ignore in order to loop over failed FTP connections # and the like): @@ -371,32 +387,77 @@ sub slxsystem } # ------------------------------------------------------------------------------ +sub cluck +{ + _doThrowOrWarn('cluck', @_); +} + +# ------------------------------------------------------------------------------ +sub carp +{ + _doThrowOrWarn('carp', @_); +} + +# ------------------------------------------------------------------------------ sub warn { - my $msg = shift; - $msg =~ s[^\*\*\* ][]igms; - $msg =~ s[^][*** ]igms; - if ($openslxConfig{'debug-confess'}) { - Carp::cluck $msg; - } else { - chomp $msg; - CORE::warn "$msg\n"; - } + _doThrowOrWarn('warn', @_); +} + +# ------------------------------------------------------------------------------ +sub confess +{ + invokeCleanupFunctions(); + _doThrowOrWarn('confess', @_); +} + +# ------------------------------------------------------------------------------ +sub croak +{ + invokeCleanupFunctions(); + _doThrowOrWarn('croak', @_); } # ------------------------------------------------------------------------------ sub die { invokeCleanupFunctions(); + _doThrowOrWarn('die', @_); +} +# ------------------------------------------------------------------------------ +sub _doThrowOrWarn +{ + my $type = shift; my $msg = shift; + $msg =~ s[^\*\*\* ][]igms; $msg =~ s[^][*** ]igms; + if ($openslxConfig{'debug-confess'}) { - confess $msg; - } else { + my %functionFor = ( + 'carp' => sub { Carp::cluck @_ }, + 'cluck' => sub { Carp::cluck @_ }, + 'confess' => sub { Carp::confess @_ }, + 'croak' => sub { Carp::confess @_ }, + 'die' => sub { Carp::confess @_ }, + 'warn' => sub { Carp::cluck @_ }, + ); + my $func = $functionFor{$type}; + $func->($msg); + } + else { chomp $msg; - CORE::die "$msg\n"; + my %functionFor = ( + 'carp' => sub { Carp::carp @_ }, + 'cluck' => sub { Carp::cluck @_ }, + 'confess' => sub { Carp::confess @_ }, + 'croak' => sub { Carp::croak @_ }, + 'die' => sub { CORE::die @_}, + 'warn' => sub { CORE::warn @_ }, + ); + my $func = $functionFor{$type}; + $func->("$msg\n"); } } @@ -406,11 +467,15 @@ sub instantiateClass my $class = shift; my $requestedVersion = shift; - unless (eval "require $class") { + my $moduleName = $class; + $moduleName =~ s[::][/]g; + $moduleName .= '.pm'; + unless (eval { require $moduleName } ) { if ($! == 2) { - die _tr("Class <%s> not found!\n", $class); - } else { - die _tr("Unable to load class <%s> (%s)\n", $class, $@); + die _tr("Module <%s> not found!\n", $moduleName); + } + else { + die _tr("Unable to load module <%s> (%s)\n", $moduleName, $@); } } if (defined $requestedVersion) { diff --git a/lib/OpenSLX/ConfigFolder.pm b/lib/OpenSLX/ConfigFolder.pm index 0c957ef5..de2df73f 100644 --- a/lib/OpenSLX/ConfigFolder.pm +++ b/lib/OpenSLX/ConfigFolder.pm @@ -14,7 +14,9 @@ package OpenSLX::ConfigFolder; use strict; -use vars qw(@ISA @EXPORT $VERSION); +use warnings; + +our (@ISA, @EXPORT, $VERSION); use Exporter; $VERSION = 1.01; @@ -30,6 +32,7 @@ $VERSION = 1.01; ################################################################################ use Carp; use OpenSLX::Basics; +use OpenSLX::Utils; sub createConfigFolderForDefaultSystem { @@ -47,29 +50,22 @@ sub createConfigFolderForDefaultSystem # create default pre-/postinit scripts for us in initramfs: my $preInitFile = "$defaultConfigPath/initramfs/preinit.local"; if (!-e $preInitFile) { - open(PREINIT, "> $preInitFile") - or die _tr("Unable to create file '%s'!", $preInitFile); - my $preInit = <<' END' + my $preInit = unshiftHereDoc(<<' END-of-HERE'); #!/bin/sh # # This script allows the local admin to extend the # capabilities at the beginning of the initramfs (stage3). # The toolset is rather limited and you have to keep in mind # that stage4 rootfs has the prefix '/mnt'. - END - ; - $preInit =~ s[^\s+][]igms; - print PREINIT $preInit; - close(PREINIT); + END-of-HERE + spitFile($preInitFile, $preInit); slxsystem("chmod u+x $preInitFile"); $result = 1; } my $postInitFile = "$defaultConfigPath/initramfs/postinit.local"; if (!-e $postInitFile) { - open(POSTINIT, "> $postInitFile") - or die _tr("Unable to create file '%s'!", $postInitFile); - my $postInit = <<' END' + my $postInit = unshiftHereDoc(<<' END-of-HERE'); #!/bin/sh # # This script allows the local admin to extend the @@ -78,11 +74,8 @@ sub createConfigFolderForDefaultSystem # that stage4 rootfs has the prefix '/mnt'. # But you may use some special slx-functions available via # inclusion: '. /etc/functions' ... - END - ; - $postInit =~ s[^\s+][]igms; - print POSTINIT $postInit; - close(POSTINIT); + END-of-HERE + spitFile($postInitFile, $postInit); slxsystem("chmod u+x $postInitFile"); $result = 1; } diff --git a/lib/OpenSLX/Translations/de.pm b/lib/OpenSLX/Translations/de.pm index 081e44e4..e98edd03 100644 --- a/lib/OpenSLX/Translations/de.pm +++ b/lib/OpenSLX/Translations/de.pm @@ -14,15 +14,20 @@ package OpenSLX::Translations::de; use strict; -use vars qw(@ISA @EXPORT $VERSION); +use warnings; -use Exporter; -$VERSION = 0.02; -@ISA = qw(Exporter); +our $VERSION = 0.02; -@EXPORT = qw(%translations); +my %translations; -use vars qw(%translations); +################################################################################ +### Implementation +################################################################################ +sub getAllTranslations +{ + my $class = shift; + return \%translations; +} ################################################################################ ### Translations @@ -352,12 +357,3 @@ use vars qw(%translations); ); 1; - - - - - - - - - diff --git a/lib/OpenSLX/Translations/posix.pm b/lib/OpenSLX/Translations/posix.pm index e1199f47..05e16ed5 100644 --- a/lib/OpenSLX/Translations/posix.pm +++ b/lib/OpenSLX/Translations/posix.pm @@ -14,15 +14,20 @@ package OpenSLX::Translations::posix; use strict; -use vars qw(@ISA @EXPORT $VERSION); +use warnings; -use Exporter; -$VERSION = 0.02; -@ISA = qw(Exporter); +our $VERSION = 0.02; -@EXPORT = qw(%translations); +my %translations; -use vars qw(%translations); +################################################################################ +### Implementation +################################################################################ +sub getAllTranslations +{ + my $class = shift; + return \%translations; +} ################################################################################ ### Translations @@ -351,18 +356,4 @@ use vars qw(%translations); ); - - - - 1; - - - - - - - - - - diff --git a/lib/OpenSLX/Utils.pm b/lib/OpenSLX/Utils.pm index 6dbd0e7c..4d11e702 100644 --- a/lib/OpenSLX/Utils.pm +++ b/lib/OpenSLX/Utils.pm @@ -18,10 +18,10 @@ use vars qw(@ISA @EXPORT $VERSION); use Exporter; $VERSION = 1.01; -@ISA = qw(Exporter); +@ISA = qw(Exporter); @EXPORT = qw( - ©File &fakeFile &linkFile &slurpFile &followLink + copyFile fakeFile linkFile slurpFile spitFile followLink unshiftHereDoc ); ################################################################################ @@ -34,73 +34,131 @@ use OpenSLX::Basics; sub copyFile { - my $fileName = shift; - my $targetDir = shift; + my $fileName = shift || croak 'need to pass in a fileName!'; + my $targetDir = shift || croak 'need to pass in target dir!'; my $targetFileName = shift || ''; - system("mkdir -p $targetDir") unless -d $targetDir; + system("mkdir -p $targetDir") unless -d $targetDir; my $target = "$targetDir/$targetFileName"; vlog(2, _tr("copying '%s' to '%s'", $fileName, $target)); if (system("cp -p $fileName $target")) { - die _tr("unable to copy file '%s' to dir '%s' (%s)", - $fileName, $target, $!); + croak( + _tr( + "unable to copy file '%s' to dir '%s' (%s)", + $fileName, $target, $! + ) + ); } + return; } sub fakeFile { - my $fullPath = shift; + my $fullPath = shift || croak 'need to pass in full path!'; my $targetDir = dirname($fullPath); - system("mkdir", "-p", $targetDir) unless -d $targetDir; + system("mkdir", "-p", $targetDir) unless -d $targetDir; if (system("touch", $fullPath)) { - die _tr("unable to create file '%s' (%s)", - $fullPath, $!); + croak(_tr("unable to create file '%s' (%s)", $fullPath, $!)); } + return; } sub linkFile { - my $linkTarget = shift; - my $linkName = shift; + my $linkTarget = shift || croak 'need to pass in link target!'; + my $linkName = shift || croak 'need to pass in link name!'; my $targetDir = dirname($linkName); - system("mkdir -p $targetDir") unless -d $targetDir; + system("mkdir -p $targetDir") unless -d $targetDir; if (system("ln -sfn $linkTarget $linkName")) { - die _tr("unable to create link '%s' to '%s' (%s)", - $linkName, $linkTarget, $!); + croak( + _tr( + "unable to create link '%s' to '%s' (%s)", + $linkName, $linkTarget, $! + ) + ); } + return; +} + +sub checkFlags +{ + my $flags = shift || confess 'need to pass in flags-hashref!'; + my $knownFlags = shift || confess 'need to pass in knownFlags-arrayref!'; + + my %known; + @known{@$knownFlags} = (); + foreach my $flag (keys %$flags) { + next if exists $known{$flag}; + cluck("flag '$flag' not known!"); + } + return; } sub slurpFile { - my $file = shift; - my $mayNotExist = shift; + my $fileName = shift || confess 'need to pass in fileName!'; + my $flags = shift || {}; + + checkFlags($flags, ['failIfMissing']); + my $failIfMissing + = exists $flags->{failIfMissing} ? $flags->{failIfMissing} : 1; - if (!open(F, "< $file") && !$mayNotExist) { - die _tr("could not open file '%s' for reading! (%s)", $file, $!); + local $/; + my $fh; + if (!open($fh, '<', $fileName)) { + return '' unless $failIfMissing; + croak _tr("could not open file '%s' for reading! (%s)", $fileName, $!); } - local $/ = undef; - my $text = <F>; - close(F); - return $text; + my $content = <$fh>; + close($fh) + or croak _tr("unable to close file '%s' (%s)\n", $fileName, $!); + return $content; +} + +sub spitFile +{ + my $fileName = shift || croak 'need to pass in a fileName!'; + my $content = shift; + + my $fh; + open($fh, '>', $fileName) + or croak _tr("unable to create file '%s' (%s)\n", $fileName, $!); + print $fh $content + or croak _tr("unable to print to file '%s' (%s)\n", $fileName, $!); + close($fh) + or croak _tr("unable to close file '%s' (%s)\n", $fileName, $!); + return; } sub followLink { - my $path = shift; + my $path = shift || croak 'need to pass in a path!'; my $prefixedPath = shift || ''; - + my $target; while (-l "$path") { $target = readlink "$path"; if (substr($target, 1, 1) eq '/') { $path = "$prefixedPath/$target"; - } else { - $path = $prefixedPath.dirname($path).'/'.$target; + } + else { + $path = $prefixedPath . dirname($path) . '/' . $target; } } return $path; } -1;
\ No newline at end of file +sub unshiftHereDoc +{ + my $content = shift; + return $content unless $content =~ m{^(\s+)}; + my $shift = length($1); + return + join "\n", + map { substr($_, $shift); } + split m{\n}, $content; +} + +1; |