81 lines
2.5 KiB
Perl
81 lines
2.5 KiB
Perl
# Selima Website Content Management System
|
|
# ChkWrite.pm: The write-permission checker.
|
|
|
|
# Copyright (c) 2005-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: 2005-02-28
|
|
|
|
package Selima::ChkWrite;
|
|
use 5.008;
|
|
use strict;
|
|
use warnings;
|
|
use base qw(Exporter);
|
|
use vars qw(@EXPORT @EXPORT_OK);
|
|
BEGIN {
|
|
@EXPORT = qw(check_writable);
|
|
@EXPORT_OK = @EXPORT;
|
|
# Prototype declaration
|
|
sub check_writable($);
|
|
}
|
|
|
|
use File::Basename qw(dirname);
|
|
|
|
use Selima::ShortCut;
|
|
|
|
# check_writable: Check the permission to write to a file.
|
|
# Input: File full pathname $file.
|
|
# Output: true if success, false if failed.
|
|
sub check_writable($) {
|
|
local ($_, %_);
|
|
my ($file, $parent);
|
|
$file = $_[0];
|
|
# Standardize it
|
|
# File exists.
|
|
if (-e $file) {
|
|
# If it is a file
|
|
return {"msg"=>N_("[_1]: It is not a file."),
|
|
"margs"=>[$file]}
|
|
if !-f $file;
|
|
# If it is writable
|
|
return {"msg"=>N_("[_1]: You have no permission to overwrite this file."),
|
|
"margs"=>[$file]}
|
|
if !-w $file;
|
|
|
|
# Not an existing file. See if we can create it.
|
|
} else {
|
|
$parent = $file;
|
|
# Find the nearest existing parent
|
|
$parent = dirname($parent)
|
|
while $parent ne "" && !-e $parent;
|
|
# Creat files from root --- You are insane
|
|
return {"msg"=>N_("[_1]: You cannot create anything under the root directory."),
|
|
"margs"=>[$file]}
|
|
if $parent eq "";
|
|
# This parent is not a directory
|
|
return {"msg"=>N_("[_1]: One of the parents of this file ([_2]) is not a directory. You cannot create any new file inside."),
|
|
"margs"=>[$file, $parent]}
|
|
if !-d $parent;
|
|
# If it is possible to create entries in this directory
|
|
return {"msg"=>N_("[_1]: You have no permission to create any file under [_2]."),
|
|
"margs"=>[$file, $parent]}
|
|
if !-w $parent;
|
|
}
|
|
# OK
|
|
return;
|
|
}
|
|
|
|
return 1;
|