Initial commit.
This commit is contained in:
232
lib/perl5/Selima/XFileIO.pm
Normal file
232
lib/perl5/Selima/XFileIO.pm
Normal file
@@ -0,0 +1,232 @@
|
||||
# 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;
|
||||
Reference in New Issue
Block a user