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