256 lines
7.7 KiB
Perl
256 lines
7.7 KiB
Perl
# Selima Website Content Management System
|
|
# PageFunc.pm: The web page related subroutines.
|
|
|
|
# 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-15
|
|
|
|
package Selima::PageFunc;
|
|
use 5.008;
|
|
use strict;
|
|
use warnings;
|
|
use base qw(Exporter);
|
|
use vars qw(@EXPORT @EXPORT_OK);
|
|
BEGIN {
|
|
@EXPORT = qw(page_param page_all_linguas hash_tree outpage rebuildtype_options);
|
|
@EXPORT_OK = @EXPORT;
|
|
# Prototype declaration
|
|
sub page_param(;$);
|
|
sub page_all_linguas($);
|
|
sub hash_tree($);
|
|
sub outpage($$;$);
|
|
sub rebuildtype_options($);
|
|
}
|
|
|
|
use Config qw(%Config);
|
|
use Devel::Symdump;
|
|
use File::Basename qw(basename dirname);
|
|
|
|
use Selima::AbsURI;
|
|
use Selima::DataVars qw($DBH :dataman :l10n :lninfo :output :rebuild :requri :scptconf);
|
|
use Selima::EchoForm;
|
|
use Selima::GetLang;
|
|
use Selima::Guest;
|
|
use Selima::LnInfo;
|
|
use Selima::MkAllDir;
|
|
use Selima::Page2Rel;
|
|
use Selima::ScptPriv;
|
|
use Selima::ShortCut;
|
|
use Selima::Unicode;
|
|
use Selima::XFileIO;
|
|
|
|
# page_param: Gather page parameters
|
|
sub page_param(;$) {
|
|
local ($_, %_);
|
|
my $args;
|
|
$args = $_[0];
|
|
# Default to an empty array
|
|
$args = {} if !defined $args;
|
|
return $args if exists $$args{".fixed"};
|
|
|
|
# Obtain page parameters
|
|
$args = {%$ALT_PAGE_PARAM, %$args} if defined $ALT_PAGE_PARAM;
|
|
$args = {%$PAGE_PARAM, %$args} if defined $PAGE_PARAM;
|
|
|
|
# Set the path
|
|
$$args{"path"} = $REQUEST_PATH
|
|
if !exists $$args{"path"};
|
|
# Set the language
|
|
$$args{"lang"} = getlang
|
|
if !exists $$args{"lang"};
|
|
# Set if static or not
|
|
$$args{"static"} = 0
|
|
if !exists $$args{"static"};
|
|
# Set if show a pretty result or not
|
|
$$args{"clean"} = 0
|
|
if !exists $$args{"clean"};
|
|
# Set if this page is administrative
|
|
$$args{"admin"} = is_admin_script $$args{"path"}
|
|
if !exists $$args{"admin"};
|
|
# Set if this is a preview page or not
|
|
$$args{"preview"} = undef
|
|
if !exists $$args{"preview"};
|
|
# Set if we shoud show the tite in html_header() or not
|
|
$$args{"no_auto_title"} = 0
|
|
if !exists $$args{"no_auto_title"};
|
|
# Set all the available languages
|
|
$$args{"all_linguas"} = [@ALL_LINGUAS]
|
|
if !exists $$args{"all_linguas"};
|
|
# Set the language of the title
|
|
$$args{"title_lang"} = $$args{"lang"}
|
|
if !exists $$args{"title_lang"};
|
|
# The upper level index page
|
|
if (!exists $$args{"up"}) {
|
|
if ($$args{"path"} !~ /\/(?:errors|picdesc)\//) {
|
|
$$args{"up"} = $$args{"path"};
|
|
$$args{"up"} =~ s/[^\/]+\/?$//;
|
|
# Remove the /cgi-bin/ directory
|
|
$$args{"up"} =~ s/\/cgi-(?:bin|perl|raw)\/$/\//;
|
|
}
|
|
}
|
|
|
|
# Load the local extension when available
|
|
$args = &$_($args) if defined $MAIN
|
|
&& defined $MAIN->can("page_param_site");
|
|
$args = &$_($args) if defined $MAIN
|
|
&& defined $MAIN->can("page_param_script");
|
|
|
|
# Tag that we have fixed it
|
|
$$args{".fixed"} = 1;
|
|
return $args;
|
|
}
|
|
|
|
# page_all_linguas: Get the available languages for this page
|
|
sub page_all_linguas($) {
|
|
local ($_, %_);
|
|
my ($page, $lndb);
|
|
$page = $_[0];
|
|
|
|
# It is specified
|
|
return @{$$page{"all_linguas"}}
|
|
if exists $$page{"all_linguas"};
|
|
|
|
# Preview
|
|
if (exists $$page{"preview"} && $$page{"preview"}) {
|
|
my ($sql, $sth, $count, $row);
|
|
# Uni-lingual
|
|
return (getlang) unless $DBH->is_ml_table($THIS_TABLE);
|
|
# Find the page
|
|
return (getlang) unless exists $$page{"sn"};
|
|
$sql = "SELECT * FROM $THIS_TABLE"
|
|
. " WHERE sn=" . $$page{"sn"} . ";\n";
|
|
$sth = $DBH->prepare($sql);
|
|
$sth->execute;
|
|
# If this record exist
|
|
return (getlang) if $sth->rows == 0;
|
|
$row = $sth->fetchrow_hashref;
|
|
# Check each language
|
|
@_ = qw();
|
|
foreach my $lang (@ALL_LINGUAS) {
|
|
$lndb = ln $lang, LN_DATABASE;
|
|
# Add it if the page for this language exists
|
|
push @_, $lang if defined $$row{"title_$lndb"}
|
|
|| $lang eq getlang;
|
|
}
|
|
return @_;
|
|
}
|
|
|
|
# $page is uni-lingual
|
|
return (getlang) if exists $$page{"title"};
|
|
|
|
# $page is multi-lingual
|
|
# Check each language
|
|
@_ = qw();
|
|
foreach my $lang (@ALL_LINGUAS) {
|
|
$lndb = ln $lang, LN_DATABASE;
|
|
# Skip if the page for this language does not exist
|
|
push @_, $lang if defined $$page{"title_$lndb"};
|
|
}
|
|
return @_;
|
|
}
|
|
|
|
# hash_tree: Make a hash of the page tree
|
|
sub hash_tree($) {
|
|
local ($_, %_);
|
|
my ($tree, %hash);
|
|
$tree = $_[0];
|
|
# The index page
|
|
$hash{${$$tree{"index"}}{"path"}} = $tree
|
|
if exists $$tree{"index"};
|
|
# Track the subdirectories
|
|
if (exists $$tree{"pages"}) {
|
|
for ($_ = 0; $_ < @{$$tree{"pages"}}; $_++) {
|
|
# A subdirectory exists
|
|
if (exists ${${$$tree{"pages"}}[$_]}{"sub"}) {
|
|
%hash = (%hash,
|
|
hash_tree ${${$$tree{"pages"}}[$_]}{"sub"});
|
|
}
|
|
}
|
|
}
|
|
return %hash;
|
|
}
|
|
|
|
# outpage: Output a page
|
|
sub outpage($$;$) {
|
|
local ($_, %_);
|
|
my ($html, $path, $lang, $file);
|
|
($html, $path, $lang) = @_;
|
|
$lang = getlang if !defined $lang;
|
|
|
|
# Convert the URLs to relative
|
|
if ($path =~ /^\/errors\//) {
|
|
$html = page2abs $html, $path;
|
|
$html =~ s/href="\/errors\/(\$url)"/href="$1"/g;
|
|
$html =~ s/href="$path(#.+?)"/href="$1"/g;
|
|
} else {
|
|
$html = page2rel $html, $path;
|
|
}
|
|
# Encode the e-mail at-signs (@)
|
|
$html =~ s/@/@/g;
|
|
# Decode the e-mail at-signs (@) of spamtrap
|
|
$html =~ s/spamtrap@/spamtrap@/g;
|
|
# Encode the page to the target character set
|
|
$html = page_encode($html, ln($lang, LN_CHARSET));
|
|
# Obtain the real file name
|
|
$file = $DOC_ROOT . $path;
|
|
$file .= "index.html" if $file =~ /\/$/;
|
|
$file .= "." . ln($lang, LN_FILENAME) if @ALL_LINGUAS > 1;
|
|
# Create the necessary directories
|
|
mkalldir dirname($file);
|
|
# Write the file
|
|
xfupdate_template "$file.xhtml", $html;
|
|
# Make the symbolic link for the text/html
|
|
if (defined $Config{"d_symlink"}) {
|
|
my ($targfile, $linkfile);
|
|
($targfile, $linkfile) = (basename("$file.xhtml"), "$file.html");
|
|
unless (-l $linkfile && readlink $linkfile eq $targfile) {
|
|
unlink $linkfile if -l $linkfile;
|
|
symlink $targfile, $linkfile;
|
|
}
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
# rebuildtype_options: Obtain a rebuild type options list
|
|
sub rebuildtype_options($) {
|
|
local ($_, %_);
|
|
my $value;
|
|
$value = $_[0];
|
|
# The type labels
|
|
%_ = (
|
|
"pages" => C_("Web pages"),
|
|
"news" => C_("News"),
|
|
"links" => C_("Related links"),
|
|
"home" => C_("Home page"),
|
|
"all" => C_("Whole web site"),
|
|
map { $_ => __($REBUILD_LABELS{$_}) } keys %REBUILD_LABELS,
|
|
);
|
|
|
|
# Get the available rebuild types
|
|
@_ = map {
|
|
"value" => $_,
|
|
"content" => (exists $_{$_}? $_{$_}: $_),
|
|
}, sort grep s/^.+::rebuild_([^:]+)$/$1/,
|
|
Devel::Symdump->new($MAIN)->functions;
|
|
# Obtain the HTML
|
|
$_ = opt_list_array @_;
|
|
|
|
return preselect_options($_, $value);
|
|
}
|
|
|
|
return 1;
|