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