233 lines
7.4 KiB
Perl
233 lines
7.4 KiB
Perl
# Selima Website Content Management System
|
|
# XFileIO.pm: The extended file input/output subroutines.
|
|
|
|
# Copyright (c) 2003-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: 2003-03-24
|
|
|
|
package Selima::XFileIO;
|
|
use 5.008;
|
|
use strict;
|
|
use warnings;
|
|
use base qw(Exporter);
|
|
use vars qw(@EXPORT @EXPORT_OK);
|
|
BEGIN {
|
|
@EXPORT = qw(xfread xfwrite xfappend xfupdate xfupdate_template);
|
|
@EXPORT_OK = @EXPORT;
|
|
# Prototype declaration
|
|
sub xfread($);
|
|
sub xfwrite($$);
|
|
sub xfappend($$);
|
|
sub xfupdate($$);
|
|
sub xfupdate_template($$;$);
|
|
sub template_updated($$$);
|
|
}
|
|
|
|
use Fcntl qw(:flock :seek);
|
|
|
|
use Selima::DataVars qw(:scptconf);
|
|
use Selima::HTTP;
|
|
|
|
# xfread: Read from a file
|
|
# Input: file path $file
|
|
# Output: file content
|
|
sub xfread($) {
|
|
local ($_, %_);
|
|
my ($FH, $file, $size);
|
|
$file = $_[0];
|
|
|
|
# Return as lines
|
|
if (wantarray) {
|
|
open $FH, $file or http_500 "$file: $!";
|
|
flock $FH, LOCK_SH or http_500 "$file: $!";
|
|
@_ = <$FH>;
|
|
flock $FH, LOCK_UN or http_500 "$file: $!";
|
|
close $FH or http_500 "$file: $!";
|
|
return @_;
|
|
|
|
# A scalar file content
|
|
} else {
|
|
# Regular files
|
|
if (-f $file) {
|
|
@_ = stat $file or http_500 "$file: $!";
|
|
$size = $_[7];
|
|
return "" if $size == 0;
|
|
open $FH, $file or http_500 "$file: $!";
|
|
flock $FH, LOCK_SH or http_500 "$file: $!";
|
|
read $FH, $_, $size or http_500 "$file: $!";
|
|
flock $FH, LOCK_UN or http_500 "$file: $!";
|
|
close $FH or http_500 "$file: $!";
|
|
return $_;
|
|
|
|
# Special files
|
|
} else {
|
|
open $FH, $file or http_500 "$file: $!";
|
|
flock $FH, LOCK_SH or http_500 "$file: $!";
|
|
$_ = join "", <$FH>;
|
|
flock $FH, LOCK_UN or http_500 "$file: $!";
|
|
close $FH or http_500 "$file: $!";
|
|
return $_;
|
|
}
|
|
}
|
|
}
|
|
|
|
# xfwrite: Write to a file
|
|
# Input: file path $file and file content $conten
|
|
# Output: none
|
|
sub xfwrite($$) {
|
|
local ($_, %_);
|
|
my ($FH, $file, $content);
|
|
($file, $content) = @_;
|
|
|
|
open $FH, ">$file" or http_500 "$file: $!";
|
|
flock $FH, LOCK_EX or http_500 "$file: $!";
|
|
print $FH $content or http_500 "$file: $!";
|
|
flock $FH, LOCK_UN or http_500 "$file: $!";
|
|
close $FH or http_500 "$file: $!";
|
|
|
|
return;
|
|
}
|
|
|
|
# xfappend: Append to a file
|
|
# Input: file path $file and file content $conten
|
|
# Output: none
|
|
sub xfappend($$) {
|
|
local ($_, %_);
|
|
my ($FH, $file, $content);
|
|
($file, $content) = @_;
|
|
|
|
open $FH, ">>$file" or http_500 "$file: $!";
|
|
flock $FH, LOCK_EX or http_500 "$file: $!";
|
|
print $FH $content or http_500 "$file: $!";
|
|
flock $FH, LOCK_UN or http_500 "$file: $!";
|
|
close $FH or http_500 "$file: $!";
|
|
|
|
return;
|
|
}
|
|
|
|
# xfupdate: Update a file
|
|
# Input: file path $file and file content $conten
|
|
# Output: none
|
|
sub xfupdate($$) {
|
|
local ($_, %_);
|
|
my ($FH, $file, $content, $size);
|
|
($file, $content) = @_;
|
|
|
|
# Write as a new file if the old file does not exist
|
|
if (!-e $file) {
|
|
open $FH, ">$file" or http_500 "$file: $!";
|
|
flock $FH, LOCK_EX or http_500 "$file: $!";
|
|
print $FH $content or http_500 "$file: $!";
|
|
flock $FH, LOCK_UN or http_500 "$file: $!";
|
|
close $FH or http_500 "$file: $!";
|
|
|
|
# Old file exists -- compare the content and update only if necessary
|
|
} else {
|
|
@_ = stat $file or http_500 "$file: $!";
|
|
$size = $_[7];
|
|
open $FH, "+<$file" or http_500 "$file: $!";
|
|
flock $FH, LOCK_SH or http_500 "$file: $!";
|
|
if ($size == 0) {
|
|
$_ = "";
|
|
} else {
|
|
read $FH, $_, $size or http_500 "$file: $!";
|
|
}
|
|
if ($_ ne $content) {
|
|
seek $FH, 0, SEEK_SET or http_500 "$file: $!";
|
|
truncate $FH, 0 or http_500 "$file: $!";
|
|
print $FH $content or http_500 "$file: $!";
|
|
}
|
|
flock $FH, LOCK_UN or http_500 "$file: $!";
|
|
close $FH or http_500 "$file: $!";
|
|
}
|
|
return;
|
|
}
|
|
|
|
# xfupdate_template: Update a file comparing with a template
|
|
# Input: the file path $file, the new content template $tmpl
|
|
# and its replacements $rep
|
|
# Output: none
|
|
sub xfupdate_template($$;$) {
|
|
local ($_, %_);
|
|
my ($FH, $file, $tmpl, $rep, $old, $new, $size);
|
|
($file, $tmpl, $rep) = @_;
|
|
# Obtain the replacements
|
|
$rep = defined($_ = $MAIN->can("page_replacements"))? &$_: {}
|
|
if !defined $rep;
|
|
|
|
# Write as a new file if the old file does not exist
|
|
if (!-e $file) {
|
|
$new = $tmpl;
|
|
$new =~ s/<!--selima:$_-->/${$$rep{$_}}{"content"}/g
|
|
foreach keys %$rep;
|
|
xfwrite($file, $new);
|
|
|
|
# Old file exists -- compare the content and update only if necessary
|
|
} else {
|
|
@_ = stat $file or http_500 "$file: $!";
|
|
$size = $_[7];
|
|
open $FH, "+<$file" or http_500 "$file: $!";
|
|
flock $FH, LOCK_EX or http_500 "$file: $!";
|
|
if ($size == 0) {
|
|
$old = "";
|
|
} else {
|
|
read $FH, $old, $size or http_500 "$file: $!";
|
|
}
|
|
# Not matched
|
|
if (template_updated $old, $tmpl, $rep) {
|
|
$new = $tmpl;
|
|
$new =~ s/<!--selima:$_-->/${$$rep{$_}}{"content"}/g
|
|
foreach keys %$rep;
|
|
seek $FH, 0, SEEK_SET or http_500 "$file: $!";
|
|
truncate $FH, 0 or http_500 "$file: $!";
|
|
print $FH $new or http_500 "$file: $!";
|
|
}
|
|
flock $FH, LOCK_UN or http_500 "$file: $!";
|
|
close $FH or http_500 "$file: $!";
|
|
}
|
|
|
|
}
|
|
|
|
# template_updated: If a page is updated comparing to the template
|
|
sub template_updated($$$) {
|
|
local ($_, %_);
|
|
my ($old, $tmpl, $rep);
|
|
($old, $tmpl, $rep) = @_;
|
|
|
|
# Process piece by piece
|
|
while ($tmpl =~ s/^(.*?)(<!--selima:(.+?)-->)(.*)$/$4/s) {
|
|
my ($plain, $repsec, $key);
|
|
($plain, $repsec, $key) = ($1, $2, $3);
|
|
|
|
# Try to match the plain text part
|
|
return 1 if $old !~ s/^\Q$plain\E//;
|
|
|
|
# A valid replacement is found -- try to match the pattern
|
|
if (exists $$rep{$key}) {
|
|
return 1 if $old !~ s/^${$$rep{$key}}{"pattern"}//;
|
|
|
|
# Not a valid replacement -- treat it as a plain text part
|
|
} else {
|
|
return 1 if $old !~ s/^\Q$repsec\E//;
|
|
}
|
|
}
|
|
# Check the remains as a plain text part
|
|
return 1 if $old ne $tmpl;
|
|
return 0;
|
|
}
|
|
|
|
return 1;
|