selima-perl/lib/perl5/Selima/MkAllDir.pm

# 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;