package Prty::Path; BEGIN { $INC{'Prty/Path.pm'} ||= __FILE__; } use base qw/Prty::Object/; use strict; use warnings; use utf8; our $VERSION = 1.112; use Prty::Option; use Prty::FileHandle; use Prty::String; use Encode (); use Fcntl qw/:DEFAULT/; use Prty::Perl; use Prty::Unindent; use File::Find (); use Prty::DirHandle; use Prty::Shell; use Prty::Process; # ----------------------------------------------------------------------------- =encoding utf8 =head1 NAME Prty::Path - Dateisystem-Operationen =head1 BASE CLASS L<Prty::Object> =head1 DESCRIPTION Die Klasse definiert alle grundlegenden (link, mkdir, rename, symlink usw.) und komplexen (copy, glob, find usw.) Dateisystem-Operationen. Eine Dateisystem-Operation ist eine Operation auf einem I<Pfad>. =head1 METHODS =head2 Datei-Operationen =head3 append() - Hänge Daten an Datei an =head4 Synopsis $class->append($file,$data); =head4 Description Hänge Daten $data an Datei $file an. Die Methode liefert keinen Wert zurück. =cut # ----------------------------------------------------------------------------- sub append { shift->write($_[0],$_[1],-append=>1); return; } # ----------------------------------------------------------------------------- =head3 compare() - Prüfe, ob Inhalt der Dateien differiert =head4 Synopsis $bool = $class->compare($file1,$file2); =head4 Description Prüfe, ob der Inhalt der Dateien $file1 und $file2 differiert. Ist dies der Fall, liefere I<wahr>, andernfalls I<falsch>. =cut # ----------------------------------------------------------------------------- sub compare { my ($class,$file1,$file2) = @_; if (-s $file1 != -s $file2) { return 1; } return $class->read($file1) eq $class->read($file2)? 0: 1; } # ----------------------------------------------------------------------------- =head3 compareData() - Prüfe, ob Datei-Inhalt von Daten differiert =head4 Synopsis $bool = $class->compareData($file,$data); =head4 Alias different() =head4 Description Prüfe, ob der Inhalt der Datei $file von $data differiert. Ist dies der Fall, liefere I<wahr>, andernfalls I<falsch>. Die Datei $file muss nicht existieren. =cut # ----------------------------------------------------------------------------- sub compareData { my $class = shift; my $file = shift; # @_: $data if (!-e $file || -s $file != length $_[0]) { return 1; } return $class->read($file) eq $_[0]? 0: 1; } { no warnings 'once'; *different = \&compareData; } # ----------------------------------------------------------------------------- =head3 copy() - Kopiere Datei =head4 Synopsis $class->copy($srcPath,$destPath,@opt); =head4 Description Kopiere Datei $srcPath nach $destPath. =head4 Options =over 4 =item -createDir => $bool (Default: 0) Erzeuge Zielverzeichnis, falls es nicht existiert. =item -preserve => $bool (Default: 0) Behalte den Zeitpunkt der letzten Änderung bei. =back =cut # ----------------------------------------------------------------------------- sub copy { my $class = shift; my $srcPath = shift; my $destPath = shift; # @_: @opt # Optionen my $createDir = 0; my $preserve = 0; if (@_) { Prty::Option->extract(\@_, -createDir=>\$createDir, -preserve=>\$preserve, ); } # Operation ausführen if ($createDir) { my ($destDir) = $class->split($destPath); $class->mkdir($destDir,-recursive=>1); } my $fh1 = Prty::FileHandle->new('<',$srcPath); my $fh2 = Prty::FileHandle->new('>',$destPath); while (<$fh1>) { print $fh2 $_ or $class->throw( q{PATH-00007: Schreiben auf Datei fehlgeschlagen}, SourcePath=>$srcPath, DestinationPath=>$destPath, ); } $fh1->close; $fh2->close; if ($preserve) { $class->mtime($destPath,$class->mtime($srcPath)); } return; } # ----------------------------------------------------------------------------- =head3 duplicate() - Kopiere, bewege, linke oder symlinke Datei =head4 Synopsis $class->duplicate($method,$srcPath,$destPath,@opt); =head4 Description Mache Datei $srcPath nach Methode $method unter $destPath verfügbar. Werte für $method: copy move -or- rename link symlink =head4 Options =over 4 =item -preserve => $bool (Default: 0) Behalte den Zeitpunkt der letzten Änderung bei (nur bei 'copy' relevant). =back =cut # ----------------------------------------------------------------------------- sub duplicate { my $class = shift; my $method = shift; my $srcPath = shift; my $destPath = shift; # @_: @opt # Optionen my $preserve = 0; if (@_) { Prty::Option->extract(\@_, -preserve=>\$preserve, ); } # Operation ausführen if ($method eq 'copy') { $class->copy($srcPath,$destPath,-preserve=>1); } elsif ($method eq 'move' || $method eq 'rename') { $class->rename($srcPath,$destPath); } elsif ($method eq 'link') { $class->link($srcPath,$destPath); } elsif ($method eq 'symlink') { $class->symlinkRelative($srcPath,$destPath); } else { $class->throw; } return; } # ----------------------------------------------------------------------------- =head3 link() - Erzeuge (Hard)Link =head4 Synopsis $class->link($path,$link); =head4 Description Erzeuge einen Hardlink $link auf Pfad $path. Die Methode liefert keinen Wert zurück. =cut # ----------------------------------------------------------------------------- sub link { my ($class,$path,$link) = @_; CORE::link $path,$link or do { $class->throw( q{FS-00002: Kann Link nicht erzeugen}, Path=>$path, Link=>$link, Error=>$!, ); }; return; } # ----------------------------------------------------------------------------- =head3 newlineStr() - Ermittele Zeilentrenner =head4 Synopsis $nl = $class->newlineStr($file); =head4 Description Ermittele den physischen Zeilentrenner (CR, LF oder CRLF) der Datei $file und liefere diesen zurück. Wird kein Zeilentrenner gefunden, liefere undef. =head4 Example local $/ = Prty::Path->newlineStr($file); while (<$fh>) { chomp; # Zeile verarbeiten } =cut # ----------------------------------------------------------------------------- sub newlineStr { my ($class,$file) = @_; my $fh = Prty::FileHandle->new('<',$file); $fh->binmode; my $nl; while (defined(my $c = getc $fh)) { if ($c eq "\cM") { $c = getc $fh; if (defined($c) && $c eq "\cJ") { $nl = "\cM\cJ"; last; } $nl = "\cM"; last; } elsif ($c eq "\cJ") { $nl = "\cJ"; last; } } $fh->close; return $nl; } # ----------------------------------------------------------------------------- =head3 read() - Lies Datei =head4 Synopsis $data = $class->read($file,@opt); =head4 Description Lies den Inhalt der Datei und liefere diesen zurück. =head4 Options =over 4 =item -autoDecode => $bool (Default: 0) Auto-Dekodiere die gelesenen Daten als Text und entscheide selbständig, ob es sich um UTF-8 oder ISO-8859-1 Encoding handelt. =item -decode => $encoding (Default: undef) Decodiere die Datei gemäß dem Encoding $encoding. =item -delete => $bool (Default: 0) Lösche Datei nach dem Lesen. =item -maxLines => $n (Default: 0) Lies höchstens $n Zeilen. Die Zählung beginnt nach den Skiplines (s. Option -skipLines). 0 bedeutet, lies alle Zeilen. =item -skip => $regex (Default: keiner) Überlies alle Zeilen, die das Muster $regex erfüllen. $regex wird als Zeichenkette angegeben. Die Option kann beispielsweise dazu verwendet werden, um Kommentarzeilen zu überlesen. =item -skipLines => $n (Default: 0) Überlies die ersten $n Zeilen. =back =cut # ----------------------------------------------------------------------------- sub read { my $class = shift; my $file = shift; # @_: Optionen # Optionen my $autoDecode = 0; my $decode = undef; my $delete = 0; my $maxLines = 0; my $skip = undef; my $skipLines = 0; if (@_) { Prty::Option->extract(\@_, -autoDecode=>\$autoDecode, -decode=>\$decode, -delete=>\$delete, -maxLines=>\$maxLines, -skip=>\$skip, -skipLines=>\$skipLines, ); } # Datei lesen my $data = ''; my $fh = Prty::FileHandle->new('<',$file); if ($maxLines || $skip || $skipLines) { my $i = 0; my $j = 0; while (<$fh>) { next if $skipLines && $i++ < $skipLines; last if $maxLines && ++$j > $maxLines; next if $skip && /$skip/; # Zeile überlesen $data .= $_; } } else { local $/ = undef; $data = <$fh>; } $fh->close; if ($delete) { $class->delete($file); } if ($decode) { $data = Encode::decode($decode,$data); } elsif ($autoDecode) { $data = Prty::String->autoDecode($data); } return $data; } # ----------------------------------------------------------------------------- =head3 write() - Schreibe Datei =head4 Synopsis $class->write($file); # leere Datei $class->write($file,$data,@opt); $class->write($file,\$data,@opt); =head4 Options =over 4 =item -append => $bool (Default: 0) Öffne die Datei im Append-Modus, d.h. hänge die Daten an die Datei an. =item -encode => $encoding (Default: keiner) Encodiere $data gemäß dem Encoding $encoding. =item -mode => $mode (Default: keiner) Setze die Permissions der Datei auf $mode. Beispiel: -mode=>0775 =item -recursive => $bool (Default: 1) Erzeuge übergeordnete Verzeichnisse, wenn nötig. =back =cut # ----------------------------------------------------------------------------- sub write { my $class = shift; my $file = shift; my $data = shift; # @_: @opt # Optionen my $append = 0; my $encode = undef; my $mode = undef; my $recursive = 1; if (@_) { Prty::Option->extract(\@_, -append=>\$append, -encode=>\$encode, -mode=>\$mode, -recursive=>\$recursive, ); } my $ref = ref $data? $data: \$data; # Erzeuge Verzeichnis, wenn nötig if ($recursive) { my $dir = (Prty::Path->split($file))[0]; if ($dir && !-d $dir) { $class->mkdir($dir,-recursive=>1); } } my $flags = Fcntl::O_WRONLY|Fcntl::O_CREAT; $flags |= $append? Fcntl::O_APPEND: Fcntl::O_TRUNC; local *F; sysopen(F,$file,$flags) || do { $class->throw( q{PATH-00006: Datei kann nicht zum Schreiben geöffnet werden}, Path=>$file, Error=>"$!", ); }; if ($encode) { Prty::Perl->binmode(*F,":encoding($encode)"); } # Wenn keine Daten zu schreiben sind, print auslassen, # da sonst eine Exception ausgelöst wird. if (defined($$ref) && $$ref ne '') { print F $$ref or do { my $errStr = "$!"; close F; Prty::Path->throw( q{PATH-00007: Schreiben auf Datei fehlgeschlagen}, Path=>$file, Error=>$errStr, ); } } close F; if (defined $mode) { # Permissions setzen $class->chmod($file,$mode); } return; } # ----------------------------------------------------------------------------- =head3 writeIfDifferent() - Schreibe Datei, wenn Inhalt differiert =head4 Synopsis $class->writeIfDifferent($file,$data); =cut # ----------------------------------------------------------------------------- sub writeIfDifferent { my $class = shift; my $file = shift; # @_: $data if ($class->compareData($file,$_[0])) { $class->write($file,$_[0]); return 1; } return 0; } # ----------------------------------------------------------------------------- =head3 writeInline() - Schreibe Inline-Daten in Datei =head4 Synopsis $class->writeInline($file,<<'__EOT__',@opt); DATA ... __EOT__ =cut # ----------------------------------------------------------------------------- sub writeInline { my ($class,$file,$data) = splice @_,0,3; # @_: @opt # Prty::String->removeIndentationNl(\$data); Prty::Unindent->hereDoc($data); $class->write($file,$data,@_); return; } # ----------------------------------------------------------------------------- =head2 Verzeichnis-Operationen =head3 find() - Liefere Pfade innerhalb eines Verzeichnisses =head4 Synopsis @paths|$pathA = $class->find($path,@opt); =head4 Description Finde alle Dateien und Verzeichnisse unterhalb von und einschließlich Verzeichnis $path und liefere die Liste der gefundenen Pfade zurück. Im Skalarkontext liefere eine Referenz auf die Liste. Ist $dir Null (Leerstring oder undef), wird das aktuelle Verzeichnis ('.') durchsucht. Die Reihenfolge der Dateien ist undefiniert. =head4 Options =over 4 =item -decode => $encoding Dekodiere die Dateinamen gemäß dem angegebenen Encoding. =item -exclude => $regex (Default: keiner) Schließe alle Pfade aus, die Muster $regex erfüllen. Directories werden gepruned. Matcht ein Pfad die Pattern sowohl von -pattern als auch -exclude, hat der exclude-Pattern Vorrang, d.h. die Datei wird ausgeschlossen. =item -follow => $bool (Default: 1) Folge Symbolic Links. =item -leavesOnly => $bool (Default: 0) Liefere nur Pfade, die kein Anfang eines anderen Pfads sind. Anwendungsfall: nur die Blatt-Verzeichnisse eines Verzeichnisbaums. =item -olderThan => $seconds (Default: 0) Liefere nur Dateien, die vor mindestens $seconds zuletzt geändert wurden. Diese Option ist z.B. nützlich, um veraltete temporäre Dateien zu finden, um sie zu löschen. =item -outHandle => $fh (Default: \*STDOUT) Filehandle, auf die Ausgabe im Falle von -verbose=>1 geschrieben werden. =item -pattern => $regex (Default: keiner) Schränke die Treffer auf jene Pfade ein, die Muster $regex erfüllen. Matcht ein Pfad die Pattern sowohl von -pattern als auch -exclude, hat der exclude-Pattern Vorrang, d.h. die Datei wird ausgeschlossen. =item -slash => $bool (Default: 0) Füge einen Slash (/) am Ende von Directory-Namen hinzu. =item -sloppy => $bool (Default: 0) Wirf keine Exception, wenn $path nicht existiert, sondern liefere undef bzw. eine leere Liste. =item -subPath => $bool (Default: 0) Liefere nur den Subpfad, entferne also $path am Anfang. =item -testSub => sub {} (Default: undef) Subroutine, die den Pfad als Argument erthält und einen boolschen Wert liefert, der angibt, ob der Pfad zur Ergebnismenge gehört oder nicht. =item -type => 'd' | 'f' | undef (Default: undef) Liefere nur Verzeichnisse ('d') oder nur, was kein Verzeichnis ist ('f'), oder liefere alles (undef). =item -verbose => $bool (Default: 0) Schreibe Meldungen auf Ausgabe-Handle (s. Option -outHandle). =back =cut # ----------------------------------------------------------------------------- sub find { my $class = shift; my $dir = shift; # @_: @opt # Optionen my $decode = undef; my $exclude = undef; my $follow = 1; my $leavesOnly = 0; my $olderThan = 0; my $outHandle = \*STDOUT; my $pattern = undef; my $slash = 0; my $sloppy = 0; my $subPath = 0; my $testSub = undef; my $type = undef; my $verbose = 0; if (@_) { Prty::Option->extract(\@_, -decode=>\$decode, -exclude=>\$exclude, -follow=>\$follow, -leavesOnly=>\$leavesOnly, -olderThan=>\$olderThan, -outHandle=>\$outHandle, -pattern=>\$pattern, -slash=>\$slash, -sloppy=>\$sloppy, -subPath=>\$subPath, -testSub=>\$testSub, -type=>\$type, -verbose=>\$verbose, ); } # Parameter-Tests if (!defined $dir || $dir eq '') { $dir = '.'; } elsif (!-e $dir) { if ($sloppy) { return wantarray? (): undef; } $class->throw(q{PATH-00011: Verzeichnis existiert nicht}, Dir=>$dir, ); } elsif (!-d $dir) { $class->throw(q{PATH-00013: Pfad ist kein Verzeichnis}, Path=>$dir, ); } # Liste der Pfade my @paths; # Zeitpunkt der Suche (für Zeitvergleich bei -olderThan) my $time = time; my $sub = sub { $File::Find::name =~ s|^\./||; # ./ am Anfang entfernen if ($exclude && $File::Find::name =~ /$exclude/) { if (-d) { # warn "PRUNE: $File::Find::name\n"; $File::Find::prune = 1; } return; } if ($pattern && $File::Find::name !~ /$pattern/) { return; } if ($type || $slash || $olderThan) { # Test muss auf $_ erfolgen, da abgestiegen wird! my $isDir = -d; if ($type) { if ($type eq 'd' && !$isDir || $type eq 'f' && $isDir) { return; } } if ($olderThan) { # Datei ist jünger als $olderThan Sekunden return if (stat $File::Find::name)[9] > $time-$olderThan; } if ($slash && $isDir) { $File::Find::name .= '/'; } } if ($testSub && !$testSub->($File::Find::name)) { return; } if ($subPath) { # Pfadanfang entfernen $File::Find::name =~ s|^\Q$dir/||; } # $File::Find::name =~ s|^\./||; # ./ am Anfang entfernen if ($verbose) { print $outHandle $File::Find::name,"\n"; } if ($decode) { push @paths,Encode::decode($decode,$File::Find::name); } else { push @paths,$File::Find::name; } }; File::Find::find({wanted=>$sub,follow=>$follow},$dir); if ($leavesOnly) { my @arr; for (my $i = 0; $i < @paths; $i++) { my $ok = 1; for (my $j = 0; $j < @paths; $j++) { if ($j != $i && index($paths[$j],$paths[$i]) == 0) { $ok = 0; last; } } if ($ok) { push @arr,$paths[$i]; } } @paths = @arr; } return wantarray? @paths: \@paths; } # ----------------------------------------------------------------------------- =head3 maxFilename() - Liefere den lexikalisch größten Dateinamen =head4 Synopsis $max = $class->maxFilename($dir); =head4 Description Liefere den lexikalisch größten Dateinamen aus Verzeichnis $dir. =cut # ----------------------------------------------------------------------------- sub maxFilename { my ($class,$dir) = @_; my $max; my $dh = Prty::DirHandle->new($dir); while (my $file = $dh->next) { if ($file eq '.' || $file eq '..') { next; } if (!defined($max) || $file gt $max) { $max = $file; } } $dh->close; return $max; } # ----------------------------------------------------------------------------- =head3 maxFileNumber() - Liefere den numerisch größten Dateinamen =head4 Synopsis $max = $class->maxFileNumber($dir,@opt); =head4 Description Liefere den numerisch größten Dateinamen aus Verzeichnis $dir. Die Methode ist nützlich, wenn die Dateinamen mit einer Zahl NNNNNN beginnen und man die Datei mit der größten Zahl ermitteln möchte um einer neu erzeugten Datei die nächsthöhere Nummer zuzuweisen. =head4 Options =over 4 =item -sloppy => $bool (Default: 0) Wirf keine Exception, wenn ein Dateiname nicht mit einer Nummer beginnt. =back =cut # ----------------------------------------------------------------------------- sub maxFileNumber { my ($class,$dir) = splice @_,0,2; # @_: @opt # Options my $sloppy = 0; Prty::Option->extract(\@_, -sloppy=>\$sloppy, ); # Verarbeitung my $max = 0; my $dh = Prty::DirHandle->new($dir); while (my $file = $dh->next) { if ($file eq '.' || $file eq '..') { next; } my ($n) = $file =~ /^(\d+)/; if (!defined($n)) { if ($sloppy) { next; } $class->throw( q{PATH-00099: Dateiname beginnt nicht mit Ziffernfolge}, File=>$file, ); } if ($n+0 > $max) { $max = $n+0; } } $dh->close; return $max; } # ----------------------------------------------------------------------------- =head3 mkdir() - Erzeuge Verzeichnis =head4 Synopsis $class->mkdir($dir,@opt); =head4 Description Erzeuge Verzeichnis. Existiert das Verzeichnis bereits, hat der Aufruf keinen Effekt. Kann das Verzeichnis nicht angelegt werden, wird eine Exception ausgelöst. =head4 Options =over 4 =item -createParent => $bool (Default: 0) Erzeuge nicht den angegebenen Pfad, sondern den Parent-Pfad. Dies ist nützlich, wenn der übergebene Pfad ein Dateiname ist, dessen Verzeichnis bei Nicht-Existenz erzeugt werden soll. Impliziert -recursive=>1, wenn nicht explizit -recursive=>0 gesetzt ist. =item -forceMode => $mode (Default: keiner) Setze Verzeichnisrechte auf $mode ohne Berücksichtigung der umask des Prozesses. =item -mode => $mode (Default: 0775) Setze Verzeichnisrechte auf $mode mit Berücksichtigung der umask des Prozesses. =item -mustNotExist => $bool (Default: 0) Das Verzeichnis darf nicht existieren. Wenn es existiert, wird eine Exception geworfen. =item -recursive => 0 | 1 (Default: 0) Erzeuge übergeordnete Verzeichnisse, wenn nötig. =back =cut # ----------------------------------------------------------------------------- sub mkdir { my $class = shift; my $dir = shift; # @_: @opt return if !$dir; my $createParent = 0; my $forceMode = undef; my $mode = 0755; my $mustNotExist = 0; my $recursive = undef; if (@_) { Prty::Option->extract(-dontExtract=>1,\@_, -createParent=>\$createParent, -forceMode=>\$forceMode, -mode=>\$mode, -mustNotExist=>\$mustNotExist, -recursive=>\$recursive, ); } if ($createParent) { ($dir) = $class->split($dir); if (!defined $recursive) { $recursive = 1; } } if (-d $dir) { if ($mustNotExist) { $class->throw( q{PATH-00005: Verzeichnis existiert bereits}, Dir=>$dir, ); } return; } if ($recursive) { my ($parentDir) = $class->split($dir); $class->mkdir($parentDir, @_, -createParent=>0, -mustNotExist=>0, -recursive=>1, ); } if (-d $dir) { # Hack, damit rekursiv erzeugte Pfade wie /tmp/a/b/c/.. # angelegt werden können. Ohne diesen zusätzlichen # Existenz-Test schlägt sonst das folgende mkdir fehl. return; } CORE::mkdir($dir,$mode) || do { $class->throw( q{PATH-00004: Kann Verzeichnis nicht erzeugen}, Path=>$dir, ); }; if ($forceMode) { $class->chmod($dir,$forceMode); } return; } # ----------------------------------------------------------------------------- =head3 rmdir() - Lösche Verzeichnis =head4 Synopsis $class->rmdir($dir); =head4 Description Lösche Verzeichnis $dir, falls dieses leer ist. Kann das Verzeichnis nicht gelöscht werden, wird eine Exception ausgelöst. =head4 Arguments =over 4 =item $dir Pfad des Verzeichnisses =back =head4 Returns nichts =cut # ----------------------------------------------------------------------------- sub rmdir { my $class = shift; my $dir = shift; CORE::rmdir($dir) || do { $class->throw( q{PATH-00005: Verzeichnis kann nicht gelöscht werden}, Path=>$dir, ); }; return; } # ----------------------------------------------------------------------------- =head2 Pfad-Operationen =head3 basename() - Grundname eines Pfads =head4 Synopsis $basename = $class->basename($path); =head4 Alias baseName() =head4 Description Liefere den Grundnamen des Pfads, d.h. ohne Pfadanfang und Extension. =cut # ----------------------------------------------------------------------------- sub basename { return (shift->split(@_))[2]; } { no warnings 'once'; *baseName = \&basename; } # ----------------------------------------------------------------------------- =head3 chmod() - Setze Zugriffsrechte =head4 Synopsis $class->chmod($path,$mode); =head4 Description Setze Zugriffsrechte $mode auf Pfad $path. =cut # ----------------------------------------------------------------------------- sub chmod { my ($class,$path,$mode) = @_; CORE::chmod $mode,$path or do { $class->throw( q{PATH-00003: Setzen von Zugriffsrechten fehlgeschlagen}, Path=>$path, Mode=>$mode, ); }; return; } # ----------------------------------------------------------------------------- =head3 delete() - Lösche Pfad (rekursiv) =head4 Synopsis $class->delete($path); =head4 Description Lösche den Pfad aus dem Dateisystem, also entweder die Datei oder das Verzeichnis einschließlich Inhalt. Es ist kein Fehler, wenn der Pfad im Dateisystem nicht existiert. Existiert der Pfad und kann nicht gelöscht werden, wird eine Exception ausgelöst. Die Methode liefert keinen Wert zurück. =cut # ----------------------------------------------------------------------------- sub delete { my ($class,$path) = @_; if (!-e $path && !-l $path) { # bei Nichtexistenz nichts tun, aber nur, wenn es # kein Symlink ist. Bei Symlinks schlägt -e fehl, wenn # das Ziel nicht existiert! } elsif (-d $path) { # Verzeichnis löschen (my $dir = $path) =~ s/'/\\'/g; # ' quoten eval {Prty::Shell->exec("/bin/rm -r '$dir' >/dev/null 2>&1")}; if ($@) { $class->throw( q{PATH-00001: Verzeichnis löschen fehlgeschlagen}, Error=>$@, Path=>$path, ); } } else { # Datei löschen if (!CORE::unlink $path) { Prty::Path->throw( q{PATH-00002: Datei löschen fehlgeschlagen}, Path=>$path, ); } } return; } # ----------------------------------------------------------------------------- =head3 expandTilde() - Expandiere Tilde =head4 Synopsis $path = $class->expandTilde($path); =head4 Description Ersetze eine Tilde am Pfadanfang durch das Home-Verzeichnis des Benutzers und liefere den resultierenden Pfad zurück. =head4 Returns Pfad (String) =cut # ----------------------------------------------------------------------------- sub expandTilde { my ($class,$path) = @_; if (!exists $ENV{'HOME'}) { $class->throw( q{PATH-00016: Environment-Variable HOME existiert nicht}, ); } $path =~ s|^~/|$ENV{'HOME'}/|; return $path; } # ----------------------------------------------------------------------------- =head3 extension() - Extension des Pfads =head4 Synopsis $ext = $class->extension($path); =head4 Description Ermittele die Extension des Pfads $path und liefere diese zurück. Besitzt der Pfad keine Extension, liefere einen Leerstring (''). =cut # ----------------------------------------------------------------------------- sub extension { my ($class,$path) = @_; return $path =~ /\.([^.]+)$/? $1: ''; } # ----------------------------------------------------------------------------- =head3 glob() - Liefere Pfade, die Shell-Pattern erfüllen =head4 Synopsis $path = $class->glob($pat); @paths = $class->glob($pat); =head4 Description Liefere die Pfad-Objekte, die Shell-Pattern $pat erfüllen. Im Skalarkontext liefere den ersten Pfad, der dann der einzig erfüllbare Pfad sein muss, sonst wird eine Exception geworfen. =cut # ----------------------------------------------------------------------------- sub glob { my ($class,$pat) = @_; my @arr = CORE::glob $pat; if (wantarray) { return @arr; } if (!@arr) { $class->throw( q{PATH-00014: Pfad existert nicht}, Pattern=>$pat, ); } elsif (@arr > 1) { $class->throw( q{PATH-00015: Mehr als ein Pfad erfüllt Muster}, Pattern=>$pat, ); } return $arr[0]; } # ----------------------------------------------------------------------------- =head3 isEmpty() - Prüfe, ob Datei oder Verzeichnis leer ist =head4 Synopsis $bool = $class->isEmpty($path); =cut # ----------------------------------------------------------------------------- sub isEmpty { my ($class,$path) = @_; if (-d $path) { local *D; my $i = 0; unless (opendir D,$path) { $class->throw( q{PATH-00005: Verzeichnis kann nicht geöffnet werden}, Path=>$path, Error=>"$!", ); } while (readdir D) { last if ++$i > 2; } closedir D; return $i <= 2? 1: 0; } else { return -z $path? 1: 0; } } # ----------------------------------------------------------------------------- =head3 mode() - Liefere Zugriffsrechte =head4 Synopsis $mode = $class->mode($path); =head4 Description Liefere die Zugriffsrechte des Pfads $path. =cut # ----------------------------------------------------------------------------- sub mode { my ($class,$path) = @_; my @stat = CORE::stat $path; unless (@stat) { $class->throw( q{PATH-00001: stat ist fehlgeschlagen}, Path=>$path, ); } return $stat[2] & 07777; } # ----------------------------------------------------------------------------- =head3 mtime() - Setze/Liefere Modifikationszeit =head4 Synopsis $mtime = $class->mtime($path); $mtime = $class->mtime($path,$mtime); =head4 Description Liefere die Zeit der letzten Modifikation des Pfads $path. Wenn der Pfad nicht existiert, liefere 0. Ist ein zweiter Parameter $mtime angegeben, setze die Zeit auf den angegebenen Wert. In dem Fall muss der Pfad existieren. =cut # ----------------------------------------------------------------------------- sub mtime { my $class = shift; my $path = shift; # @_: $mtime if (@_) { my $mtime = shift; if (!-e $path) { $class->throw( q{PATH-00011: Pfad existiert nicht}, Path=>$path, ); } my $atime = (stat($path))[8]; # atime lesen, die nicht ändern if (!utime $atime,$mtime,$path) { $class->throw( q{PATH-00012: Kann mtime nicht setzen}, Path=>$path, Error=>"$!", ); } } return (stat($path))[9] || 0; } # ----------------------------------------------------------------------------- =head3 newer() - Vergleiche Modifikationsdatum zweier Pfade =head4 Synopsis $bool = $class->newer($path1,$path2); =head4 Description Prüfe, ob Pfad $path1 ein jüngeres Modifikationsdatum besitzt als $path2. Ist dies der Fall, liefere 1, andernfalls 0. Liefere ebenfalls 1, wenn Datei $path2 nicht existiert. Pfad $path1 muss existieren. Pfad $path2 kann eine Zeichenkette oder ein Pfad-Objekt sein. Dieser Test ist nützlich, wenn $path2 aus $path1 erzeugt wird und geprüft werden soll, ob eine Neuerzeugung notwendig ist. =cut # ----------------------------------------------------------------------------- sub newer { my ($class,$path1,$path2) = @_; if (!-e $path1) { $class->throw( q{PATH-00011: Pfad existiert nicht}, Path=>$path1, ); } my $t1 = (stat $path1)[9]; my $t2 = (stat $path2)[9] || 0; return $t1 > $t2? 1: 0; } # ----------------------------------------------------------------------------- =head3 rename() - Benenne Pfad um =head4 Synopsis $class->rename($oldPath,$newPath,@opt); =head4 Description Benenne Pfad $oldPath in $newPath um. Die Methode liefert keinen Wert zurück. =head4 Options =over 4 =item -overwrite => $bool (Default: 1) Wenn gesetzt, wird die Datei $newPath überschrieben, falls sie existiert. Wenn nicht gesetzt, wird eine Exception geworfen, falls sie existiert. =item -recursive => 0 | 1 (Default: 0) Erzeuge nicht-existente Verzeichnisse des Zielpfads und entferne leere Verzeichnisse des Quellpfads. =back =head4 Example Zielpfad erzeugen, Quellpfad entfernen mit -recursive=>1. Ausgangslage: Unterhalb von /tmp existieren weder a noch x. my $srcPath = '/tmp/a/b/c/d/f'; my $destPath = '/tmp/x/b/c/d/f'; Prty::Path->write($srcPath,'',-recursive=>1); Prty::Path->rename($srcPath,$destPath,-recursive=>1); Nach Ausführung existiert der der Pfad /tmp/x/b/c/d/f, aber der Pfad /tmp/a nicht mehr. =cut # ----------------------------------------------------------------------------- sub rename { my $class = shift; my $oldPath = shift; my $newPath = shift; # @_: @opt # Optionen my $overwrite = 1; my $recursive = 0; Prty::Option->extract(\@_, -overwrite=>\$overwrite, -recursive=>\$recursive, ); if (!$overwrite && -e $newPath) { $class->throw( q{PATH-00099: Zieldatei existiert bereits}, Path=>$newPath, ); } # Erzeuge Zielverzeichnis, wenn nicht vorhanden if ($recursive) { my $newDir = (Prty::Path->split($newPath))[0]; if ($newDir && !-d $newDir) { $class->mkdir($newDir,-recursive=>1); } } CORE::rename $oldPath,$newPath or do { $class->throw( q{PATH-00010: Kann Pfad nicht umbenennen}, Error=>"$!", OldPath=>$oldPath, NewPath=>$newPath, ); }; # Lösche Quellverzeichnisse, sofern sie leer sind if ($recursive) { while (1) { ($oldPath) = Prty::Path->split($oldPath); eval {Prty::Path->rmdir($oldPath)}; if ($@) { last; } } } return; } # ----------------------------------------------------------------------------- =head3 split() - Zerlege Pfad in seine Komponenten =head4 Synopsis ($dir,$file,$base,$ext) = $class->split($path); =head4 Description Zerlege Pfad in die vier Komponenten Verzeichnisname, Dateiname, Basisname (= Dateiname ohne Extension) und Extension und liefere diese zurück. Für eine Komponente, die nicht existiert, wird ein Leerstring geliefert. =cut # ----------------------------------------------------------------------------- sub split { my ($class,$path) = @_; my ($dir,$file,$base,$ext) = ('') x 4; $dir = $1 if $path =~ s|(.*)/||; $file = $path; $ext = $1 if $path =~ s/\.([^.]+)$//; $base = $path; return ($dir,$file,$base,$ext); } # ----------------------------------------------------------------------------- =head3 symlink() - Erzeuge Symlink =head4 Synopsis $class->symlink($path,$symlink); =head4 Description Erzeuge Symlink $symlink für Pfad $path. Die Methode liefert keinen Wert zurück. =cut # ----------------------------------------------------------------------------- sub symlink { my ($class,$path,$symlink) = @_; CORE::symlink $path,$symlink or do { $class->throw( q{FS-00001: Kann Symlink nicht erzeugen}, Path=>$path, Symlink=>$symlink, Error=>$!, ); }; return; } # ----------------------------------------------------------------------------- =head3 symlinkRelative() - Erzeuge Symlink mit relativem Zielpfad =head4 Synopsis $class->symlinkRelative($path,$symlink,@opt); =head4 Description Erzeuge einen Symlink $symlink, der auf den Pfad $path verweist. Die Methode liefert keinen Wert zurück. Die Methode zeichnet sich gegenüber der Methode symlink() dadurch aus, dass sie, wenn $path ein relativer Pfad zum ist, diesen so korrigiert, dass er von Pfad auch von $symlink aus korrekt ist. Denn der Pfad $path ist als relativer Pfad die Fortsetzung von $symlink! =head4 Options =over 4 =item -dryRun => $bool (Default: 0) Führe das Kommando nicht aus. Speziell Verbindung mit -verbose=>1 sinnvoll, um Code zu testen. =item -verbose => $bool (Default: 0) Gib Informationen über die erzeugten Symlinks auf STDOUT aus. =back =head4 Example Prty::Path->symlinkRelative('a','x') # x => a Prty::Path->symlinkRelative('a/b','x') # x => a/b Prty::Path->symlinkRelative('a/b','x/y') # x/y => ../a/b Prty::Path->symlinkRelative('a/b','x/y/z') # x/y/z => ../../a/b =cut # ----------------------------------------------------------------------------- sub symlinkRelative { my $class = shift; my $path = shift; my $symlink = shift; my %opt = @_; my $dryRun = delete $opt{'-dryRun'}; my $verbose = delete $opt{'-verbose'}; if (%opt) { $class->throw( q{FILESYS-00001: Unbekannte Option(en)}, Options=>join(', ',keys %opt), ); } # Sonderbehandlung, wenn der Pfad $path, auf den der Symlink zeigt, # relativ ist. Da der Pfad $path relativ zum Symlink gilt # und nicht relativ zum aktuellen Verzeichnis des Aufrufers # interpretiert wird, muss der Zielpfad ergänzt werden, # wenn der Symlink-Pfad nicht im aktuellen Verzeichnis liegt. # Die Pfad-Umschreibung nimmt diese Methode vor. if ($path !~ m|^/| && $symlink =~ m|/|) { if ($symlink !~ m|^/|) { # Wenn $symlink relativ ist, $path die Anzahl der # $symlink-Directories voranstellen my $n = $symlink =~ tr|/||; my $prefix = ''; for (my $i = 0; $i < $n; $i++) { $prefix .= '../'; } $path = "$prefix$path"; } else { # Wenn $symlink absolut ist, $path das aktuelle # Verzeichnis voranstellen. $path = sprintf '%s/%s',Prty::Process->cwd,$path; } } if ($verbose) { print "$symlink => $path\n"; } if (!$dryRun) { $class->symlink($path,$symlink); } return; } # ----------------------------------------------------------------------------- =head1 VERSION 1.112 =head1 AUTHOR Frank Seitz, L<http://fseitz.de/> =head1 COPYRIGHT Copyright (C) 2017 Frank Seitz =head1 LICENSE This code is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut # ----------------------------------------------------------------------------- 1; # eof