#!perl ###################################################################### ### ### IMPORTANT! ### Please read the warranty and legal notice ### at the end of this file! ### ###################################################################### # Alles, was ich immer wieder brauche require 5.000; package slutil; use Exporter (); @ISA = qw(Exporter); @EXPORT = qw( BetterMkdir KillSlash KillSlashAtEnd FileCopyPreserveAll FileCopySecure myfind df CreateUniqueFile GetTempDir dosglob BetterGlob FileAge GetSelfExtractorType StartePassendesProgramm diff TesteRemoteCopy TesteRemoteShell date shortdate longdate packer int2dotint min max uptime readkey ReadWithoutEcho $FCS_MOVE $FCS_COPY $FCS_PRINT $FCS_NOPRINT printumlaute printumlautepaged findpager which $osname $platform $slash $slashsuch $TRUE $FALSE ); # Die letztem kommen von slmini.pm $version = '2007.1122'; $VERSION = $version+0; use Config; use English; use File::Copy; use File::Basename; use File::Find; use FileHandle; use Time::ParseDate; use slmini 2000.0316; ###################################################################### ### Variablen ###################################################################### if ( ($osname eq "dos") || ($osname eq "MSWin32") || ($osname eq "os2") ) { fileparse_set_fstype("MSDOS") } # So kann man testen, ob das System Symlinks hat oder nicht: # $symlink_exists = (eval 'symlink("","");', $@ eq ''); ###################################################################### ### KillSlash ###################################################################### sub KillSlash { # Diese Funktion vernichtet fuehrende oder abschliessende "/" # platformunabhaengig, also unter DOS "\". # Bsp.: "/pub/comp/platforms/" wird zu "pub/comp/platforms" # $_ = $_[0]; s/^($slashsuch)*(.*?)($slashsuch)*$/$2/o; return $_; } ###################################################################### ### KillSlashAtEnd ###################################################################### sub KillSlashAtEnd { # Diese Funktion vernichtet nur abschliessende "/" # plattformunabhängig, also unter DOS "\". # Bsp.: "/pub/comp/platforms/" wird zu "/pub/comp/platforms" # $_ = shift; s/^(.*?)($slashsuch)*$/$1/o; return $_; }; ###################################################################### ### FileCopyPreserveAll ###################################################################### sub FileCopyPreserveAll { # Es wird ganz normal kopiert, mit File::Copy # Danach wird der Zeitstempel und der Besitzer korrigiert. # Das heißt, daß dieses File: # -rwxr-xr-x 1 loescher users 30266 Feb 8 15:44 libiti312.flt* # nach dem Kopieren durch Root noch dieselben Rechte und Time hat. # Es bleiben auch Links samt Rechte und Owner erhalten. # Return-Wert: identisch mit File::Copy() bzw. symlink() # if ( !defined $_[1] ) { warn "Fehler: FileCopyPreserveAll mit zuwenig Parameter aufgerufen" } my $quelle = $_[0]; my $ziel = $_[1]; my $errorcode = 0; return $FALSE unless -e $quelle; # Unter DOS kann File::Copy() keine Verzeichnisse anlegen! if ($osname eq "dos") { my $dirname = $ziel; $dirname = dirname($dirname); BetterMkdir($dirname) unless -d $dirname; } # Wenn die Quelle ein Link ist if (-l $quelle) { $errorcode = symlink(readlink($quelle),$ziel); } # Quelle ist ein normales File else { if ( defined $_[2] ) { $errorcode = copy($quelle, $ziel, $_[2]) } else { $errorcode = copy($quelle, $ziel) } } # Einlesen der Original-Werte my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, $atime,$mtime,$ctime,$blksize,$blocks) = lstat($quelle); # Setzen der Werte chown $uid, $gid, $ziel if ($osname ne "dos"); # Auf Links KEIN utime und chmod, weil sich sonst das Original ändert! unless (-l $ziel) { utime $atime, $mtime, $ziel; chmod $mode, $ziel; } return $errorcode; } ###################################################################### ### Date ###################################################################### sub date { # Liefert das aktuelle Datum in der Form: # 'Fri Feb 28 19:48:58 1997' # Diese sind identisch: # print `date`; # startet Sub-Prozess # print date; # intern # return scalar localtime; } ###################################################################### ### ShortDate ###################################################################### sub shortdate { # Liefert das aktuelle oder übergebene Datum in der Form: # 'jjjjmmtt', z.B. '19970228' # Verwendung: # print shortdate; my $time = shift || time(); return sprintf("%.2d",(localtime($time))[5]+1900) . sprintf("%.2d",(localtime($time))[4]+1) . sprintf("%.2d",(localtime($time))[3]); } ###################################################################### ### LongDate ###################################################################### sub longdate { # Liefert das aktuelle oder übergebene Datum in der Form: # 'jjjjmmtthhmmss' , z.B. '19970228093827' # Verwendung: # print longdate; my $time = shift || time(); return sprintf("%.2d",(localtime($time))[5]+1900) . sprintf("%.2d",(localtime($time))[4]+1) . sprintf("%.2d",(localtime($time))[3]) . sprintf("%.2d",(localtime($time))[2]) . sprintf("%.2d",(localtime($time))[1]) . sprintf("%.2d",(localtime($time))[0]); } ###################################################################### ### BetterMkdir ###################################################################### sub BetterMkdir { # Parameter: (Verzeichnisname) # oder: (Verzeichnisname, mode, uid, gid, atime, mtime) # # Es werden nicht vorhandene Verzeichnisse angelegt. # Bsp.: Es existiert bereits: /tmp/test # BetterMkdir("/tmp/test/neu/subdir/ganzunten") # legt den ganzen Pfad an. (Das kann mkdir() nicht!) # # Return: $TRUE bei Erfolg, sonst $FALSE # my $input = shift; my ($mode,$uid,$gid,$atime,$mtime) = @_; my $leading = ""; if (substr($input,0,1) eq $slash) { $leading = $slash; $input = substr($input,1); } # alt und gut, aber unter DOS gehts nicht:my @verz = split(/$slashsuch/, $input); # Unter DOS gibt es sowohl "/" (intern) als auch "\". my @verz = split(/[\\\/]/, $input); my $dir = $leading; my $i; my $error = 0; for ($i=0; $i<=$#verz; $i++) { $dir = $dir . $verz[$i]; if ( (! -e $dir) ) { mkdir($dir,0777) || $error++; } $dir .= $slash; } # Eigenschaften setzen if (defined $mtime) { chown $uid, $gid, $leading.$input if ($osname ne "dos"); utime $atime, $mtime, $leading.$input; chmod $mode, $leading.$input; } return ($error > 0 ? $FALSE : $TRUE); } ###################################################################### ### RenameSecure ###################################################################### sub RenameSecure { # Parameter: Filename # Return: neuer Filename # Es wird darauf geachtet, daß "neuer Filename" noch nicht existiert. # my $file = shift; my $input; my ($name,$path,$suffix) = fileparse($file,''); NOCHMALRENAME: print "Alter Name des Files: $name\n"; print "Neuer Name des Files: "; chomp($input = ); $input = $path.$input; print "Kompletter Name ist: $input\n"; # Test, ob schon ein File mit diesem Namen existiert if (-e $input) { print "Es existiert bereits ein File mit diesem Namen!\n"; goto NOCHMALRENAME; } rename($file,$input) || warn "Fehler beim Umbennenen!\n"; return $input; } ###################################################################### ### FileCopySecure ###################################################################### $FCS_MOVE = $TRUE; $FCS_COPY = $FALSE; $FCS_PRINT = $TRUE; $FCS_NOPRINT = $FALSE; sub FileCopySecure { # Aufruf: FileCopySecure(Quellfile, Zielfile, MOVE, PRINT) # Nicht vorhandene Ziel-Pfade werden automatisch erstellt. # Wenn das Ziel-File bereits existiert, dann wird nachgefragt, # ob es überschrieben werden soll. # Optionen: # Wenn MOVE==TRUE, dann wird das Quellfile gelöscht, wenn das Kopieren # erfolgreich war. # Wenn PRINT==TRUE, dann werden Textausgaben erzeugt. # # Es können die vordefinierten Konstanten zur besseren Lesbarkeit # verwendet werden: # $FCS_MOVE, $FCS_COPY, $FCS_PRINT, $FCS_NOPRINT # my ($quelle,$ziel,$move,$print) = @_; my $nameinput; if (! -e $quelle) { warn "Quellfile '$quelle' existiert nicht!\n"; return; } if ($print) { my $action = $move ? "move " : "copy "; # Zeilenumbruch, wenn es zu lang wird: my $newline = (length("$action$quelle -> $ziel") > 79) ? "\n" : ""; print "$action$quelle$newline -> $ziel\n"; } # Pfad erstellen my $pfad = dirname($ziel); if ( ! -e $pfad ) { &BetterMkdir($pfad) }; # Testen, ob Zielfile schon existiert if ( -e $ziel) { print "Zielfile existiert bereits!\n"; NOCHMALFRAGEN: print "Quellfile: "; &PrintInformation($quelle); print "Zielfile: "; &PrintInformation($ziel ); printumlaute "1. Weiter mit nächstem File\n" . "2. Überschreiben des Zielfiles\n" . "3. File unter neuem Namen kopieren\n". "4. Bestehendes Zielfile umbenennen\n". "5. Passendes Programm mit beiden Files starten\n". "6. Beide Files vergleichen (diff)\n"; my $input = readkey(); print "\n"; # Falsche Eingaben abfangen unless ($input =~ /[1-6]/) { printumlaute "Bitte wählen Sie eine Ziffer von 1 bis 6.\n"; goto NOCHMALFRAGEN; } # Weiter mit nächstem File return if ($input =~ /1/); # Überschreiben # (direkt weiter...) # Neuen Zielnamen verwenden if ($input =~ /3/) { my ($qname,$qpath,$qsuffix) = fileparse($quelle,''); my ($zname,$zpath,$zsuffix) = fileparse($ziel ,''); print "Mit welchem Namen soll das File kopiert werden?\n"; NOCHMALNAME: print "Alter Name des Files: $qname\n"; print "Neuer Name des Files: "; chomp($nameinput = ); $nameinput = $zpath.$nameinput; print "Kompletter Name ist: $nameinput\n"; # Test, ob schon ein File mit diesem Namen existiert if (-e $nameinput) { print "Es existiert bereits ein File mit diesem Namen!\n"; goto NOCHMALNAME; } $ziel = $nameinput; } # Zielfile umbenennen if ($input =~ /4/) { print "Zielfile umbenennen:\n"; RenameSecure($ziel); } if ($input =~ /5/) { print "Starte Programm für Quelle und Ziel im Hintergrund ...\n\n"; StartePassendesProgramm($quelle,$TRUE); StartePassendesProgramm($ziel,$TRUE); goto NOCHMALFRAGEN; } if ($input =~ /6/) { print "\nDie Files sind ", (diff($quelle,$ziel) == $TRUE ? "UNTERSCHIEDLICH" : "identisch"), "\n"; goto NOCHMALFRAGEN; } } if ( copy($quelle, $ziel) ) # Erfolgreich? { if ($move) { unlink($quelle); } } else { print "### FEHLER beim Kopieren von $quelle\n"; printumlaute "### (File $quelle wurde nicht gelöscht.)" if ($move); } } ###################################################################### ### PrintInformation ###################################################################### sub PrintInformation { # Es wird Information über ein File ausgegeben. # Als Parameter wird der Filename übergeben # (Verwendung in den FileCopy-Funktionen) my $file = shift; my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, $atime,$mtime,$ctime,$blksize,$blocks) = stat($file); print sprintf("%12d", $size), " Bytes ", sprintf("%.2d.",(localtime($mtime))[3]), sprintf("%.2d.",(localtime($mtime))[4]+1), sprintf("%.2d ",1900+(localtime($mtime))[5]), " ", sprintf("%.2d:",(localtime($mtime))[2]), sprintf("%.2d:",(localtime($mtime))[1]), sprintf("%.2d",(localtime($mtime))[0]), "\n"; } ###################################################################### ### readkey ###################################################################### sub readkey { # Liest ein einzelnes Zeichen von der Tastatur. my $key; if ($osname eq "dos") { chomp($key = ); } else { # select STDIN; $| = 1; select STDOUT; # open(STTY, "stty|") || die "Kann 'stty' nicht ausführen!\n"; # my @stty = ; # close STTY; # my $IstSchonICANON = grep(/icanon/, @stty); # system("stty -icanon") unless $IstSchonICANON; # $key = getc; # system("stty icanon eol ^@") unless $IstSchonICANON; # Besser: # use Term:ReadKey; # open(TTY, "; $key = substr($key,0,1); } else { if ($BSD_STYLE) { system "stty cbreak /dev/tty 2>&1" } else { system "stty", '-icanon', 'eol', "\001" } $key = getc(STDIN); if ($BSD_STYLE) { system "stty -cbreak /dev/tty 2>&1" } else { system "stty", 'icanon', 'eol', '^@' } print ""; } } return $key; } ###################################################################### ### packer ###################################################################### sub packer # # Aufruf: # packer(filename, archivtyp, action); # Bsp.: packer("test.tgz", "tgz", "LIST"); # Es wird die komplette Kommandozeile zurückgegeben. # Bsp.: "gzip -cd test.tgz | tar -tvf -" # Das ermöglicht zwei Vaianten: # 1. system( packer(...) ) # 2. open(XXX, packer(...)."|") # # Bei Aufruf ohne Parameter wird eine Liste aller bekannten Archivformate # zurückgegeben. # # Bei Aufruf mit nur einem Parameter wird TRUE zurückgegeben, wenn das # Archivformat unterstützt wird: # packer("zip") ergibt TRUE # { my %packer = ( arj_EXTR => 'unarj x FILENAME', arj_LIST => 'unarj l FILENAME', lha_EXTR => 'lha x FILENAME', lha_LIST => 'lha l FILENAME', lzh_EXTR => 'lha x FILENAME', lzh_LIST => 'lha l FILENAME', rar_EXTR => 'unrar x FILENAME', rar_LIST => 'unrar l FILENAME', rpm_EXTR => 'rpm2cpio < FILENAME | cpio -vidm --no-absolute-filenames', rpm_LIST => 'rpm -qlp FILENAME', tar_EXTR => 'tar -xvpf FILENAME', tar_LIST => 'tar -tvf FILENAME', tgz_EXTR => 'gzip -cd FILENAME | tar -xvpf -', # tbz_LIST => 'cat FILENAME | bzip2 -d | tar -tvf -', # tbz_EXTR => 'cat FILENAME | bzip2 -d | tar -xvpf -', # tbz2_LIST => 'cat FILENAME | bzip2 -d | tar -tvf -', # tbz2_EXTR => 'cat FILENAME | bzip2 -d | tar -xvpf -', tbz_LIST => 'bzip2 -cd FILENAME | tar -tvf -', tbz_EXTR => 'bzip2 -cd FILENAME | tar -xvpf -', tbz2_LIST => 'cat FILENAME | bzip2 -d | tar -tvf -', tbz2_EXTR => 'cat FILENAME | bzip2 -d | tar -xvpf -', tgz_LIST => 'gzip -cd FILENAME | tar -tvf -', 'tar.gz_EXTR' => 'gzip -cd FILENAME | tar -xvpf -', 'tar.gz_LIST' => 'gzip -cd FILENAME | tar -tvf -', 'tar.z_EXTR' => 'uncompress -c FILENAME | tar -xvpf -', 'tar.z_LIST' => 'uncompress -c FILENAME | tar -tvf -', 'tar.Z_EXTR' => 'uncompress -c FILENAME | tar -xvpf -', 'tar.Z_LIST' => 'uncompress -c FILENAME | tar -tvf -', 'tar.bz2_LIST' => 'bzip2 -cd FILENAME | tar -tvf -', 'tar.bz2_EXTR' => 'bzip2 -cd FILENAME | tar -xvpf -', zip_EXTR => 'unzip -d FILENAME', zip_LIST => 'unzip -l FILENAME', ); # Workaround für "UnZip 5.20 of 30 April 1996, by Info-ZIP", da der Schalter # "-d" falsch verstanden wird my $temp; if ($temp = which('unzip')) { $temp = `$temp`; $temp =~ /UnZip (\d+\.\d+) /; if (defined $1 && ($1 > 5.20) ) { $packer{zip_EXTR} = 'unzip FILENAME'; } } # Liste der bekannten Formate zurückgeben unless (defined $_[0]) { return ('arj','lha','lzh','rar','rpm','tar','tbz','tbz2','tgz','tar.gz', 'tar.z','tar.Z','tar.bz2','zip'); } # Antworten, ob dieses Format unterstützt wird $_[0] =~ s/^\.//; return defined ($packer{"${_[0]}_EXTR"}) unless defined $_[1]; my ($file,$typ,$action) = @_; # Falls ".zip" statt "zip" übergeben wird, dann kann man das tolerieren: $typ =~ s/^\.//; # Fehlerabfragen if ( ($action ne "LIST") && ($action ne "EXTR") ) { die "packer(): Falscher Parameter 'action'!\n" } unless ( -r $file ) { die "packer(): File '$file' nicht lesbar!\n" } unless ( defined $packer{"${typ}_$action"} ) { die "packer(): File-Typ '$typ' unbekannt!\n" } # Text-Ersetzung des Filenamens: my $command = $packer{"${typ}_$action"}; $command =~ s/FILENAME/$file/g; return $command; } ###################################################################### ### myfind ###################################################################### sub myfind { # Parameter: # - ohne Parameter: aktuelles Verzeichnis ist Anfangsverzeichnis # - erster Parameter: Ausgangsverzeichnis, in dem der Find starten soll # Dieser Find findet genau dasselbe, wie unter Unix: # find $anfangsdir -print # Return: Liste der Files # my $startdir; if (defined $_[0]) { $startdir = shift } else { $startdir = "." } my @filelist = (); if ($osname eq 'dos') { @filelist = dosfind($startdir) } else { find(sub{push @filelist,$File::Find::name}, $startdir) } return @filelist; } ###################################################################### ### dosfind ###################################################################### sub dosfind { # Unter DOS funktioniert File::Find() nicht, weil Readdir() nicht # funktioniert. Deshalb verwende ich im Augenblick Novell-xdir. # # Parameter: # - ohne Parameter: aktuelles Verzeichnis ist Anfangsverzeichnis # - erster Parameter: Ausgangsverzeichnis, in dem der Find starten soll # Dieser Find findet genau dasselbe, wie unter Unix: # find $anfangsdir -print # my $startdir; if (defined $_[0]) { $startdir = shift } else { $startdir = "." } die "Kann 'xdir' nicht finden!\n" unless which("xdir.exe"); my @filelist = `xdir /sb $startdir`; foreach (@filelist) { chomp; } return @filelist; } ###################################################################### ### df ###################################################################### sub df { # Macht dasselbe wie das Unix-"df"-Kommando # Parameter: Gerät, z.B. "/dev/sda" # oder gemountetes (Unter-)Verzeichnis, z.B. "/mnt/dosf/temp/" # Return: undefined oder freien Speicher in Bytes. # my $dir = shift; my $frei = undef; # Alpha : "dec_osf" # HPUX : "hpux" # SUN : "solaris" my $unix = ( ($osname eq "linux") || ($osname eq "aix" ) ) || $FALSE; my $dos = ($osname eq "dos") || $FALSE; if (!$unix && !$dos) { print "'df' fuer '$osname' sind noch nicht unterstuetzt\n"; return undef; } if ($unix) { # Das führt unter Linux je nach Version der libc zu einem Segfault! # # Erste Methode: syscall() # # Voraussetzung: # # int statfs(const char *path, struct statfs *buf); # # # #struct statfs { # # long f_type; /* type of filesystem (see below) */ # # long f_bsize; /* optimal transfer block size */ # # long f_blocks; /* total data blocks in file system */ # # long f_bfree; /* free blocks in fs */ # # long f_bavail; /* free blocks avail to non-superuser */ # # long f_files; /* total file nodes in file system */ # # long f_ffree; /* free file nodes in fs */ # # fsid_t f_fsid; /* file system id */ # # long f_namelen; /* maximum length of filenames */ # # long f_spare[6]; /* spare for later */ # #}; # # # my $result = undef; # my $long = "\0" x $Config{intsize}; # my $tmp = $long x 10; # eval # { # eval # { # package main; # require "syscall.ph"; # } # and # $result = (syscall(&main::SYS_statfs, $dir, $tmp) == 0) ? $tmp : undef; # }; # if (defined $result) # { # my ($type,$bsize,$blocks,$bfree,$bavail) = unpack('L10',$result); # $frei = $bsize*$bavail; # # print "syscall an statfs() lieferte: # #Blocksize: $bsize # #Total: $blocks # #Free: $bfree # #Avail: $bavail # #Es sind also ",$frei/1024," KBytes frei\n"; # } # else # { # Zweite Methode df(8) # die "Kann 'df' nicht finden!\n" unless defined which "df"; my ($device,$total,$used,$available,$capacity,$mountpoint); my $df = 'df -k -P'; # Linux $df = 'df -k -I' if ($osname eq 'aix'); open(DF, "$df $dir|") || die "Fehler bei 'df'!\n"; while () { # Ich parse einen Text der Form: # Linux: # Filesystem 1024-blocks Used Available Capacity Mounted on # /dev/sdb5 220932 137576 83356 62% /mnt/dosd # Oder: # Filesystem 1024-blocks Used Available Capacity Mounted on # /dev/scsi/host0/bus0/target0/lun0/disc # 221956 131268 90688 59% /mnt/mo # Bei NFS: # tgx055:/export/home 204800 118564 86236 58% /export/home # ($device,$total,$used,$available,$capacity,$mountpoint) = split; if ( ($device =~ /^\//) || ($device =~ /^.*?:\//) ) { $frei = $available*1024; last; } } close DF; # } } else # DOS { # Das Ende eines "dir"s unter MSDOS-DOS schaut so aus: # TEST BAK 85 13.05.97 15:34 # TEST PL 87 13.05.97 15:35 # 12 Datei(en) 166693 Byte # 739999744 Byte frei # # Unter Novell-DOS: # AUTOEXEC BAK 1,078 6-02-97 6:01p # AUTOEXEC BAT 1,078 6-08-97 2:15p # 37 Datei(en) 330,053 Bytes # 614,400 Bytes frei # $dir = KillSlashAtEnd($dir); my @diroutput = `dir $dir`; foreach (@diroutput) { # MS-DOS: return $1 if /(\d+) Byte frei/; # Novell-DOS: if ( /([\d,]+) Bytes frei/ ) { my $temp = $1; $temp =~ s/,//g; return $temp; }; } # Andernfalls return undef; } return $frei; } ###################################################################### ### int2dotint ###################################################################### sub int2dotint { # Eingabe: Eine Integer-Zahl, z.B. '123456789' # Ausgabe: Zahl mit Punkten zur Tausender-Trennung, z.B. '123.456.789' # my $input = shift; 1 while ($input =~ s/^(-?\d+)(\d{3})/$1.$2/); return $input; } ###################################################################### ### CreateUniqueFile ###################################################################### sub CreateUniqueFile { # Erstellt ein leeres File mit eindeutigem Namen # Parameter: (Vorschlag, Liste von Verzeichnissen) # z.B.: "syncdir", ".", "/tmp" # Return: Name des Files (mit kompletten Pfad) oder "". # my ($prefix,@dirs) = @_; my $name = ""; my $dir = ""; my $MaxLen = 1000; $MaxLen = 8 if $osname eq 'dos'; # Nur die ersten 8 Zeichen unter DOS $prefix = substr($prefix,0,$MaxLen); # Nächstes schreibbares Verzeichnis while ($dir=shift @dirs) { last if (-d $dir && -w $dir); } return '' unless defined $dir; $name = $dir . $slash . $prefix . ".tmp"; # Nächster nicht existierender Filename my $count = $$; my $lcount; while (-e $name) { $lcount = length($count); if ($lcount > $MaxLen) { $count = substr($count,0,$MaxLen); $count = $count/2; $lcount = length($count); } $name = $dir . $slash . substr($prefix,0,$MaxLen-$lcount) . $count .".tmp"; $count++; } my $fh = FileHandle->new(); open($fh, ">$name") || return ''; close $fh; return $name; } ###################################################################### ### GetTempDir ###################################################################### sub GetTempDir { # keine Parameter # Return: Name des TEMP-Verzeichnisses # my @dirs = ("/tmp","c:/temp"); if (defined $ENV{HOME}) { push @dirs, "$ENV{HOME}/tmp", "$ENV{HOME}/temp"; } push @dirs,$ENV{TMP} if defined $ENV{TMP}; push @dirs,$ENV{TEMP} if defined $ENV{TEMP}; push @dirs,"."; foreach $dir (@dirs) { return $dir if (-d $dir && -w $dir); } } ###################################################################### ### min ###################################################################### sub min { # Gibt das Minimum der übergebenen Zahlen zurück return (sort {$a<=>$b} @_)[0]; } ###################################################################### ### max ###################################################################### sub max { # Gibt das Maximum der übergebenen Zahlen zurück return (sort {$b<=>$a} @_)[0]; } ###################################################################### ### uptime ###################################################################### sub uptime { # Parameter: keine # Return: Load wie Uptime (3 Werte) # AIX-uptime liefert: # 04:48PM up 26 days, 3:55, 11 users, load average: 0.38, 0.27, 0.18 my $up = `uptime`; $up =~ /load average: ([\d\.]+), ([\d\.]+), ([\d\.]+)$/; return wantarray ? ($1,$2,$3) : $1; } ###################################################################### ### dosglob ###################################################################### sub dosglob { # Gleiche Funktion, wie glob(). # Unter DOS funktioniert mit Perl5 das interne glob() nicht, weil # dazu eine /bin/sh benötigt. # my $such = shift; my $files = `dir /b $such`; @files = split(/\n/,$files); return @files; } ###################################################################### ### FileAge ###################################################################### sub FileAge { # Parameter: Filename # Return: Alter des Files in Sekunden # return ( parsedate(scalar localtime) - parsedate(scalar localtime((stat(shift))[9])) ); } ###################################################################### ### GetSelfExtractorType ###################################################################### sub GetSelfExtractorType { # Stellt fest, von welchem Packer ein Self-Extractor erstell wurde # Parameter: Filename # Return: echte Endung wie 'arj' oder undef(), # my $file = shift; open (FILE, "<$file") || do { print "'$file' kann nicht gelesen werden.\n"; return undef; }; # Die ersten 200 Bytes binär einlesen $SuchPuffer = ''; read (FILE,$SuchPuffer,1024); close FILE; $_ = $SuchPuffer; if (!/^MZ/) { print "'$file' ist kein DOS-Executable!\n"; return undef; } else { abfrage: { if (/PKLITE/) { return 'zip' } if (/This is a Windows self-extracting ZIP file./) { return 'zip' } if (/RJSX/) { return 'arj' } if (/LHA\'s SFX/) { return 'lha' } if (/B_winzip_/) { return 'zip' } # sonst: return undef; } } } ###################################################################### ### StartePassendesProgramm ###################################################################### sub StartePassendesProgramm { # Es wird das zum File-Typ passende Programm aufgerufen # z.B. "xv" für "jpg" # Parameter: (Filename, Hintergrund) # Wenn Hintergrund TRUE, dann wird das Programm im Hintergrund gestartet. # my $file = shift; my $hintergrund = shift || $FALSE; $hintergrund = $hintergrund ? '&' : ''; my $userfile = "$ENV{HOME}/.runrc"; return unless -e $file; my ($name,$path,$suffix) = fileparse($file,'\.[^\.]*'); $suffix =~ s/^\.//; # Standard-Einstellungen my %prog = ( jpg => 'xv', gif => 'xv', ); if (-e $userfile) { # Benutzer-Einstellungen einlesen my $fh = FileHandle->new(); open($fh,$userfile); while(<$fh>) { warn "Parse-Error in $userfile: '$_'\n" unless /^([^\s]+)\s+:\s+(.+)$/; $prog{$1} = $2; } close $fh; } $suffix = lc $suffix; unless (defined $prog{$suffix}) { warn "Unbekannter File-Typ: '$suffix'\n"; return; } system("$prog{$suffix} $file $hintergrund"); } ###################################################################### ### diff ###################################################################### sub diff { # Vergleich von zwei Files # Parameter: (File1, File2) # Return: # $FALSE = 0 = Files identisch (different? -> No! ) # $TRUE = 1 = Files unterschiedlich (different? -> Yes!) # undef bei Fehler # (identisch mit denen des normalen diff.) # my ($file1,$file2)=@_; unless (-r $file1 && -r $file2) # Lesbar? { warn "'diff': Kann eines der Files nicht lesen!\n"; return undef; } unless (which "diff") { warn "Kann 'diff' nicht finden!\n"; return undef; } # Wenn Files unterschiedlich groß sind return $TRUE if ( -s $file1 != -s $file2 ); system ("diff $file1 $file2 > /dev/null"); my $ret = ($?>>8); return ($ret == 0 ? $FALSE : $TRUE ); } ###################################################################### ### ReadWithoutEcho ###################################################################### sub ReadWithoutEcho { # Einlesen ohne Echo. z.B. zur Paßworteingabe # Parameter: Prompttest, FileHandle, z.B. ("Paßwort: ", "STDIN") # Return: Eingabe # my $prompt = shift; my $fh = shift; my $input = ''; if ( ($osname ne 'aix') && ($osname ne 'linux') ) { printumlaute "\nACHTUNG: Die Paßwort-Routine ist für '$osname' noch ungetestet! Das zeichenweise unsichtbare Eingeben funktioniert evtl. noch nicht richtig! Bitte melden Sie mir dies, da Terminals systemabhängig sind. Bei Anonymous-Login wird das Paßwort zur Kontrolle ausgegeben.\n"; } printumlaute $prompt; system("stty -echo"); chomp($input = <$fh>); system("stty echo"); return $input; } ###################################################################### ### TesteRemoteShell ###################################################################### sub TesteRemoteShell { # Parameter: Rechnername, Optionen-Hash # Return: 'ssh', 'rsh', 'ssh-passwd', 'none' # # Es wird festgestellt, welche Verbindungsmöglichkeit zu einem Rechner # besteht. Dazu wird dieses der Reihe nach versucht: # - ssh # - rsh # - ssh mit Paßwortabfrage # # Mögliche Optionen: # - "remote_user" gibt den User an, mit dem ssh/rsh versucht werden soll. # Wenn "debug" gesetzt ist, dann werden Debug-Infos ausgegeben. # - "ssh_key" gibt den Ort des ssh-Keys, der verwendet werden soll an. # - "debug" : Zum Fehlersuchen. # # Beispiel: TesteRemoteShell('myhost', remote_user=>'myuser', ssh_key=>'/home/myotheruser/.ssh/id_dsa', debug=>1); # my $host = shift || die "TesteRemoteShell() ohne Parameter aufgrufen!\n"; my %options = @_; my $null = '2>/dev/null >/dev/null'; my $user = ''; my $ssh_key = ''; my $debug = $FALSE; # Nur gültige Optionen "durchlassen" foreach (keys %options) { if (/remote_user/) { $user = $options{remote_user} } elsif (/ssh_key/) { $ssh_key = $options{ssh_key}; } elsif (/debug/) { $debug = $TRUE; } else { die "TesteRemoteShell() mit falscher Option '$_' aufgrufen!\n"; } } print "Debug-Call an TesteRemoteShell().\n" if $debug; if ($user ne '') { $user = "-l $user "; } if ($ssh_key ne '') { $ssh_key = "-i $ssh_key "; } # ssh print "Teste ssh...\n" if $debug; if (which('ssh')) { system("ssh ${user}${ssh_key}-o 'FallBackToRsh no' -o 'BatchMode yes' -o 'StrictHostKeyChecking no' $host echo TEST $null"); if ( ($?>>8) == 0 ) { return 'ssh'; } } # rsh print "Teste rsh...\n" if $debug; system("rsh $host ${user}echo TEST $null"); if ( ($?>>8) == 0 ) { return 'rsh'; } # ssh mit Paßwortabfrage print "Teste ssh mit Paßwortabfrage...\n" if $debug; if (which('ssh')) { system("ssh ${user}${ssh_key}-o 'FallBackToRsh no' $host echo TEST"); if ( ($?>>8) == 0 ) { return 'ssh-passwd'; } } return 'none'; } ###################################################################### ### TesteRemoteCopy ###################################################################### sub TesteRemoteCopy { # Parameter: Rechnername, Optionen-Hash # Return: 'scp ...', 'rcp', 'rsync ...', 'none' # # (Bei scp und rsync wird gleich eine passende Kommandozeile gebildet.) # Es wird festgestellt, welche Kopiermöglichkeit zu einem Rechner # besteht. Dazu dieses der Reihe nach versucht: # - rsync mit ssh # - rsync mit rsh # - scp # - rcp # # Mögliche Optionen: # - "remote_user" gibt den User an, mit dem ssh/rsh versucht werden soll. # - "ssh_key" gibt den Ort des ssh-Keys, der verwendet werden soll an. # - "debug" : Zum Fehlersuchen. # # Beispiel: TesteRemoteCopy('myhost', remote_user=>'myuser', ssh_key=>'/home/myotheruser/.ssh/id_dsa', debug=>1); # $host = shift || die "TesteRemoteCopy() ohne Parameter aufgrufen!\n"; my $null = '2>/dev/null >/dev/null'; my $rsync_opt = '-z -t -L'; my %options = @_; my $user = ''; my $user_l = ''; my $user_at = ''; my $ssh_key = ''; my $debug = $FALSE; # Nur gültige Optionen "durchlassen" foreach (keys %options) { if (/remote_user/) { $user = $options{remote_user}; $user_l = "-l $user "; $user_at = "$user\@"; } elsif (/ssh_key/) { $ssh_key = $options{ssh_key}; } elsif (/debug/) { $debug = $TRUE; } else { die "TesteRemoteCopy() mit falscher Option '$_' aufgrufen!\n"; } } if ($ssh_key ne '') { $ssh_key = "-i $ssh_key "; } print "Debug-Call an TesteRemoteCopy().\n" if $debug; print "Remote_User: '$user'\n" if $debug; my $test_rsh_result = TesteRemoteShell($host,%options); my $verzeichnisse = ' $HOME/bin/rsync /usr/local/bin/rsync /usr/bin/rsync '. '/bin/rsync /usr/local/sbin/rsync /usr/sbin/rsync /root/bin/rsync '; # Gibt es lokalen rsync? if (which('rsync')) { # Funktioniert die ssh? if ( $test_rsh_result =~ /^ssh/ ) { # rsync mit ssh print "Teste rsync mit ssh...\n" if $debug; system("rsync $rsync_opt -e \'ssh ${user_l}${ssh_key}-x\' --dry-run $0 $host:/tmp $null"); if ( ($?>>8) == 0 ) { return "rsync $rsync_opt -e \'ssh ${user_l}${ssh_key}-x\'"; } # Erfolglos, also erst einmal herausfinden, wo der rsync sich auf dem # remote-Rechner befindet print "Versuche rsync mit ssh zu finden...\n" if $debug; my @list = `ssh ${user_l}${ssh_key}$host 'ls $verzeichnisse 2>/dev/null'`; print @list if $debug; if (defined $list[0]) { my $pfad = $list[0]; chomp $pfad; # rsync mit ssh und Pfad print "Teste rsync mit ssh und Pfad '$pfad'...\n" if $debug; system("rsync $rsync_opt -e \'ssh ${user_l}${ssh_key}-x\' --rsync-path=$pfad --dry-run $0 $host:/tmp $null"); if ( ($?>>8) == 0 ) { return "rsync $rsync_opt -e \'ssh ${user_l}${ssh_key}-x\' --rsync-path=$pfad"; } } return "scp ${ssh_key}-C -o 'CompressionLevel 9'"; } else { # rsync mit rsh print "Teste rsync mit rsh...\n" if $debug; system("rsync $rsync_opt --dry-run $0 ${user_at}$host:/tmp $null"); if ( ($?>>8) == 0 ) { return "rsync $rsync_opt"; } # Erfolglos, also erst einmal herausfinden, wo der rsync sich auf dem # remote-Rechner befindet print "Versuche rsync mit rsh zu finden...\n" if $debug; my @list = `rsh $host ${user_l}'ls $verzeichnisse 2>/dev/null'`; print "Nach Versuch rsync mit rsh zu finden.\n" if $debug; print @list if $debug; if (defined $list[0]) { my $pfad = $list[0]; chomp $pfad; # rsync mit rsh und Pfad print "Teste rsync mit rsh und Pfad '$pfad'...\n" if $debug; system("rsync $rsync_opt --rsync-path=$pfad --dry-run $0 ${user_at}$host:/tmp $null"); if ( ($?>>8) == 0 ) { return "rsync $rsync_opt --rsync-path=$pfad"; } } return 'rcp'; } } else { # Ohne rsync print "Kann lokal keinen rsync finden!\n" if $debug; # Funktioniert die ssh? print "Teste scp ...\n" if $debug; if ( $test_rsh_result =~ /^ssh/ ) { return "scp ${ssh_key}-C -o 'CompressionLevel 9'"; } print "Teste rcp ...\n" if $debug; if ( $test_rsh_result eq 'rsh' ) { return 'rcp'; } } return 'none'; } ###################################################################### ### BetterGlob ###################################################################### sub BetterGlob { # Parameter: wie Perl-glob # Return: wie Perl-glob # Es werden auch Files mit Spaces richtig verarbeitet. # my $muster = shift; my @files = (); foreach (`/bin/ls -d1 $muster`) { chomp; push @files, $_; } return @files; } ###################################################################### # Return TRUE: 1; ###################################################################### # # Warranty and legal notice # ~~~~~~~~~~~~~~~~~~~~~~~~~ # # Copyright (c) 1997 by Stephan Löscher - all rights reserved # My address: Stephan Löscher, Dr.Troll-str. 3, 82194 Gröbenzell, Germany # Email: loescher@gmx.de # WWW: http://www.loescher-online.de/ # # This program is freeware. # It is NOT Public-Domain-Software! # The author (Stephan Löscher) does NOT give up his copyright, but he # reserves his copyright. Usage and copying is free of charge for private # use, but NOT for commercial use! # # You may and should copy this program free of charge, use it, # give it to your friends, upload it to a BBS or something similar, under # the following conditions: # * Don't charge any money for it. If you upload it to a BBS, make sure that # it can be downloaded free (without paying for downloading it, except # for usage fees that have to be paid anyway). Small copying fees (up to # 5 DM or 3 $US) may be charged. # * Only distribute the whole original package, with all the files included. # * This program may not be part of any commercial product or service without # the written permission by the author. # * If you want to include this program on a CD-ROM and/or book, please send # me a free copy of the CD/book (this is not a must, but I would appreciate # it very much). # # Distribution of the program is explicitly desired, provided that the above # conditions are accepted. # # YOU ARE USING THIS PROGRAM AT YOUR OWN RISK! THE AUTHOR (STEPHAN LÖSCHER) # IS NOT LIABLE FOR ANY DAMAGE OR DATA-LOSS CAUSED BY THE USE OF THIS PROGRAM # OR BY THE INABILITY TO USE THIS PROGRAM. IF YOU ARE NOT SURE ABOUT THIS, OR # IF YOU DON'T ACCEPT THIS, THEN DO NOT USE THIS PROGRAM! # BECAUSE OF THE VARIOUS HARDWARE AND SOFTWARE ENVIRONMENTS INTO WHICH THIS # PROGRAM MAY BE PUT, NO WARRANTY OF FITNESS FOR A PARTICULAR PURPOSE IS # OFFERED. # GOOD DATA PROCESSING PROCEDURE DICTATES THAT ANY PROGRAM BE THOROUGHLY # TESTED WITH NON-CRITICAL DATA BEFORE RELYING ON IT. # # No part of the documentation may be reproduced, transmitted, transcribed, # stored in any retrieval system, or translated into any other language in # whole or in part, in any form or by any means, whether it be electronic, # mechanical, magnetic, optical, manual or otherwise, without prior written # consent of the author, Stephan Löscher. # # You may not make any changes or modifications to this software or this # manual. You may not decompile, disassemble, or otherwise reverse-engineer # the software in any way. # If you got the source, then you are permitted to modify it if you # contact me and tell me your enhancements. # You also may include the source as a whole or parts of it into other # programs, as long as you don't make profit directly out of selling # the result. If you re-use code of this program then do not remove my name! # If you include this source-code in your projects, mark it clearly as such # "... derived from code XXX by Stephan Löscher". # But don't distribute modified code! # # If you believe your copy of this software has been tampered or altered in # anyway, shape or form, please contact me immediately! Do not hesitate a # moment to inform me. Remember, this software should be available to all, in # the original form, so please do not accept modified or damaged versions of # my software. # # The author reserves his right for taking legal steps if the copyright or the # license agreement is violated. # # All product names mentioned in this software are trademarks or registered # trademarks of their respective owners. # # If you have any questions, ideas, suggestions for improvements or if you find # bugs (I don't hope so.) then feel free to contact me. (Email is appreciated.) # # I'm not a native english speaker. If you are one and discover some strange # sounding parts in this documentation or in the program, please, feel free # to point it out to me and give me suggestions for alteration! # # If the program works for you, and you want to honour my efforts, you are # invited to donate as much as you want... :) # # In any case, if you don't like the restrictions in this license, contact # me, and we can work something out. # ###################################################################### ##--------------- #Local Variables: #eval:(outl-mouse-minor-mode 1) #eval:(hide-body) #End: # If you want to display only the outline of this file, say "y"