Initial commit.

lib/perl5/Selima/MkAllDir.pm

@@ -0,0 +1,169 @@
+# Selima Website Content Management System
+# MkAllDir.pm: The subroutines to create/remove directories and subdirectories at once.
+
+#  Copyright (c) 2004-2018 imacat.
+#
+#  Licensed under the Apache License, Version 2.0 (the "License");
+#  you may not use this file except in compliance with the License.
+#  You may obtain a copy of the License at
+#
+#      http://www.apache.org/licenses/LICENSE-2.0
+#
+#  Unless required by applicable law or agreed to in writing, software
+#  distributed under the License is distributed on an "AS IS" BASIS,
+#  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+#  See the License for the specific language governing permissions and
+#  limitations under the License.
+
+# Author: imacat <imacat@mail.imacat.idv.tw>
+# First written: 2004-10-25
+
+package Selima::MkAllDir;
+use 5.008;
+use strict;
+use warnings;
+use base qw(Exporter);
+use vars qw(@EXPORT @EXPORT_OK);
+BEGIN {
+@EXPORT = qw(mkalldir rmoldpage rmoldfile);
+@EXPORT_OK = @EXPORT;
+# Prototype declaration
+sub mkalldir($);
+sub rmoldpage($;$);
+sub rmoldfile($;$);
+sub dir_not_empty($);
+}
+
+use File::Spec;
+use File::Basename qw(dirname);
+
+use Selima::DataVars qw(:l10n :lninfo :requri);
+use Selima::HTTP;
+use Selima::LnInfo;
+use Selima::XFileIO;
+
+# mkalldir: Create all the components of a directory
+# Input: Directory name $dir.  It does not check at all.
+sub mkalldir($) {
+    local ($_, %_);
+    $_ = $_[0];
+    # Standardize it
+    $_ = File::Spec->canonpath($_);
+    @_ = File::Spec->splitdir($_);
+    $_ = File::Spec->catdir(shift @_);
+    while (@_ > 0) {
+        $_ = File::Spec->catdir($_, shift @_);
+        next if -e $_;
+        mkdir $_        or http_500 "$_: $!";
+    }
+    return;
+}
+
+# rmoldpage: Remove the old page before creating a new one
+# Input: The old page path $oldpage to be removed, and an optional new page
+#        path $newpage to be compared with.  It does not check at all.
+#        Path is without $DOC_ROOT
+sub rmoldpage($;$) {
+    local ($_, %_);
+    my ($oldpage, $newpage, $oldfile, $newfile);
+    ($oldpage, $newpage) = @_;
+    
+    $oldpage =~ s/\/$/\/index.html/;
+    # The new file is supplied to be compared with
+    if (defined $newpage) {
+        $newpage =~ s/\/$/\/index.html/;
+        # Return if unchanged
+        return if $oldpage eq $newpage;
+    }
+    
+    $oldfile = $DOC_ROOT . $oldpage;
+    if (defined $newpage) {
+        $newfile = $DOC_ROOT . $newpage;
+        rmoldfile($oldfile, $newfile);
+    } else {
+        rmoldfile($oldfile);
+    }
+    return;
+}
+
+# rmoldfile: Remove the old file before creating a new one
+# Input: The old file $oldfile to be removed, and an optional new file
+#        $newfile to be compared with.  It does not check at all
+sub rmoldfile($;$) {
+    local ($_, %_);
+    my ($oldfile, $newfile, $parent, @dirs);
+    ($oldfile, $newfile) = @_;
+    
+    # The new file is unchanged
+    return if defined $newfile && $oldfile eq $newfile;
+    
+    # Obtain the parent directory
+    $parent = dirname($oldfile);
+    # Return if its parent is not a directory
+    return unless -d $parent;
+    # Remove the file
+    @_ = qw();
+    push @_, ($oldfile, "$oldfile.html", "$oldfile.xhtml");
+    foreach my $lnfile (map ln($_, LN_FILENAME), @ALL_LINGUAS) {
+        push @_, ("$oldfile.$lnfile", "$oldfile.$lnfile.html", "$oldfile.$lnfile.xhtml");
+    }
+    foreach (@_) {
+        next unless -f $_ || -l $_;
+        # We can delete this file
+        if (-w $parent) {
+            unlink $_;
+        # We cannot delete the file -- Empty it if possible
+        } else {
+            xfwrite $_, "" if -f $_ && -w $_;
+        }
+    }
+    
+    # Get all sections of the new file
+    if (defined $newfile) {
+        @_ = File::Spec->splitdir(dirname($newfile));
+        for ($_ = 1, @dirs = (File::Spec->catdir($_[0])); $_ < @_; $_++) {
+            unshift @dirs, File::Spec->catdir($dirs[0], $_[$_]);
+        }
+        %_ = map { $_ => 1 } @dirs;
+    } else {
+        %_ = qw();
+    }
+    # Get all sections of the old file
+    @_ = File::Spec->splitdir($oldfile);
+    for ($_ = 1, @dirs = (File::Spec->catdir($_[0])); $_ < @_; $_++) {
+        unshift @dirs, File::Spec->catdir($dirs[0], $_[$_]);
+    }
+    
+    # Remove the parents as much as possible and necessary
+    for ($_ = 0; $_ < @dirs - 1; $_++) {
+        # Coincident with the new path ends
+        return if exists $_{$dirs[$_]};
+        # Skip to the next parent if directory not exists
+        next if !-e $dirs[$_];
+        # We cannot remove, or the directory is not empty
+        return if !-w $dirs[$_+1] || !-d $dirs[$_] || dir_not_empty $dirs[$_];
+        # Remove this directory
+        rmdir $dirs[$_];
+    }
+}
+
+# dir_not_empty: Check if a directory is empty
+sub dir_not_empty($) {
+    local ($_, %_);
+    my ($dir, $DH);
+    $dir = $_[0];
+    
+    opendir $DH, $dir           or http_500 "$dir: $!";
+    while (defined($_ = readdir $DH)) {
+        # A real entry is found
+        if ($_ ne "." && $_ ne "..") {
+            closedir $DH        or http_500 "$dir: $!";
+            return 1;
+        }
+    }
+    # No real entry was found
+    closedir $DH                or http_500 "$dir: $!";
+    return 0;
+}
+
+return 1;