home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
rtsi.com
/
2014.01.www.rtsi.com.tar
/
www.rtsi.com
/
OS9
/
FAQ
/
cgi-bin
/
discus4_00
/
source
/
fcn-html.pl
< prev
next >
Wrap
Text File
|
2009-11-06
|
7KB
|
245 lines
# FILE: fcn-html.pl
# DESCRIPTION: HTML to formatting tags converstion; auto-activations
#-------------------------------------------------------------------------------
# DISCUS COPYRIGHT NOTICE
#
# Discus is copyright (c) 2002 by DiscusWare, LLC, all rights reserved.
# The use of Discus is governed by the Discus License Agreement which is
# available from the Discus WWW site at:
# http://www.discusware.com/discus/license
#
# Pursuant to the Discus License Agreement, this copyright notice may not be
# removed or altered in any way.
#-------------------------------------------------------------------------------
use strict;
use vars qw($GLOBAL_OPTIONS $DCONF $PARAMS);
###
### activate_links
###
### Converts URLs and e-mail addresses to links
###
sub activate_links {
my ($text, $FORMref, $noactivate_tags) = @_;
return $text if $FORMref->{active_links} == 0 && $FORMref->{active_links_a};
return $text if ! $FORMref->{active_links_a} && $text =~ /\\\S+\{.+\}/s;
my $default_open_tag = ('topurl', 'newurl', 'link')[0+$GLOBAL_OPTIONS->{default_autoactivate_frameset}];
if (! defined $PARAMS->{webtags_no_active}) {
my $wtc = defined $PARAMS->{webtags_conf} ? $PARAMS->{webtags_conf} : readfile("$DCONF->{admin_dir}/webtags.conf", "read_tags", { no_lock => 1, no_unlock => 1 });
$PARAMS->{webtags_conf} = $wtc;
foreach $_ (@{$wtc}) {
next if /^#/ || ! /\S/;
$_ = trim($_);
if (my ($evaltag, $cont, $code, $act) = m|^(\*?)([cC0-9sSmM]\*?)\s*(\S+)\s*(.*)|) {
$code = char_convert(lc($code));
if ($cont =~ /\*$/) {
$PARAMS->{webtags_no_active}->{$code} = 1;
}
}
}
$PARAMS->{webtags_no_active}->{form} = 1;
}
my $noactive_tags = "imagelink|topurl|link|newurl|mail|";
$noactive_tags .= join("|", keys %{$PARAMS->{webtags_no_active}}) if ref $PARAMS->{webtags_no_active} eq 'HASH';
$noactive_tags =~ s/\|$//;
my @u = split(/\\(?:$noactive_tags)\{.*?\}/io, $text);
my @v = (); while ($text =~ /\\($noactive_tags)\{.*?\}/gio) { push @v, $&; };
# New code to prevent interference with tags that take URLs:
# my @u = split (/\\\S+\{(?:[^\s\}\\]|\\,)+,/o, $text);
# my @v = (); while ($text =~ /(\\\S+\{(?:[^\s\}\\]|\\,)+,)/og) { push @v, $1; }
foreach my $u (@u) {
my $after = $u; my $m = "";
W1: while ($after =~ m%(https?://|www\.)([\w\-\.\+/~\%\?\&\=\:\,\#\^]+)%i) {
$after = $'; my ($before, $one, $two) = ($`, $1, $2);
if ($two !~ /^([\w\-]+)\.([\w\-]+)/) {
$m .= join("", $before, $one, $two);
next W1;
}
my $url = join("", $one, $two);
$one = join("", "http://", $one) if $one !~ /^https?:/i;
my $url_link = join("", $one, $two);
if ($url =~ m|([\.\:\;\,])$|) {
$url = $`; $after = "$1$after";
}
$url_link = $` if $url_link =~ m|([\.\:\;\,])$|;
$url_link =~ s/,(.)/\%2C$1/g;
$m .= join("", $before, "\\$default_open_tag\{$url_link,$url}");
}
$u = join("", $m, $after);
$after = $u; $m = "";
W2: while ($after =~ m%(ftp?://|ftp\.)([\w\-\.\+/~\%\?\&\=\:\,]+)%i) {
$after = $'; my ($before, $one, $two) = ($`, $1, $2);
if ($two !~ /^([\w\-]+)\.([\w\-]+)/) {
$m .= join("", $before, $one, $two);
next W2;
}
my $url = join("", $one, $two);
$one = join("", "ftp://", $one) if $one !~ /^ftp:/i;
my $url_link = join("", $one, $two);
if ($url =~ m|([\.\:\;\,])$|) {
$url = $`; $after = "$1$after";
}
$url_link = $` if $url_link =~ m|([\.\:\;\,])$|;
$url_link =~ s/,(.)/\%2C$1/g;
$m .= join("", $before, "\\$default_open_tag\{$url_link,$url}");
}
$u = join("", $m, $after);
$after = $u; $m = "";
W3: while ($after =~ m|([\w\-\+\.]+)\@([\w\-\+\.]+)|i) {
$after = $';
my ($url, $before) = (join("", $1, "\@", $2), $`);
if ($url =~ m|([\.\:\;\,])$|) {
$url = $`; $after = "$1$after";
}
my $url_link = $url;
$url_link = $` if $url_link =~ m|([\.\:\;\,])$|;
$url_link =~ s/,(.)/\%2C$1/g;
$m .= join("", $before, "\\mail\{$url_link,$url}");
}
$u = join("", $m, $after);
$after = $u; $m = "";
}
foreach my $v (@v) {
if ($v =~ /^\\(\w+)\{(.*?),(.*)\}/) {
my ($tag, $url, $aft) = ($1, $2, $3);
if ($url =~ /^([\w\-]+)\.([\w\-]+)\.([\w\-]+)/) {
$url = join("", "http://", $url);
}
$v = join("", "\\", $tag, '{', $url, ",", $aft, "}");
}
}
my $message = "";
while (scalar(@u) + scalar(@v)) {
$message .= shift @u; $message .= shift @v;
}
return $message;
}
###
### html_to_webtags
###
### Converts incoming unvalidated user HTML into Discus formatting tags
###
sub html_to_webtags {
my ($text, $FORMref) = @_;
return $text if $FORMref->{html} == 0 && $FORMref->{html_a};
return $text if ! $FORMref->{html_a} && $text =~ /\\\S+\{.+\}/s;
my $u = readfile("$DCONF->{admin_dir}/htmlconvert.conf", "html_to_webtags", { no_lock => 1, no_unlock => 1});
my @X = grep(/\S/, grep(!/^\s*#/, @{ $u }));
my @j = (); my $defs = {};
study $text;
foreach my $line (@X) {
my ($cmd, $tag, $start, $end) = split_html_webtags_line($line);
if ($cmd =~ /o/i) {
$defs->{$start} = $end;
} else {
next if $text !~ /$start/i;
next if $text !~ /$end/i;
$tag =~ s/\[\\n\]/\n/g;
push @j, { start => $start, end => $end, tag => $tag };
}
}
my @u = split(/<.*?>/, $text);
my @v = (); while ($text =~ /(<.*?>)/g) { push @v, reorder_tag_arguments($1, $defs); }
$text = "";
while (scalar(@u) + scalar(@v)) {
$text .= shift @u; $text .= shift @v;
}
foreach my $j (@j) {
if ($text =~ /$j->{start}/) {
while (my @r = $text =~ /(.*)$j->{start}(.*?)$j->{end}/is) {
my $after = $'; my $before = $`;
my $one = shift @r;
my @a = splice @r, 0, scalar(@r)-1;
my $txt = shift @r;
my $ttg = $j->{tag};
$ttg =~ s/\$(\d+)/$a[$1-1]/ge;
$ttg =~ s/\$\'/$txt/g;
$text = join("", $before, $one, $ttg, $after);
}
}
}
return $text;
}
###
### give_base_tag
###
### Determines which tag is being passed
###
sub give_base_tag {
my ($text) = @_;
if ($text =~ /<\s*([^\s>]+)/) {
my $o = case_lower($1);
return $o;
}
return undef;
}
###
### reorder_tag_arguments
###
### Reorders arguments within a tag, deletes superfluous arguments
###
sub reorder_tag_arguments {
my ($usertag, $defs) = @_;
my $bt = case_lower(give_base_tag($usertag));
return join($bt, "<", ">") if ! defined $bt || ! defined $defs->{$bt};
my $u = {};
while ($usertag =~ /\s(\w+)\s*=\s*['"]?(.*?)['"\s>]/g) {
my $o = case_lower($1);
my $z = $2;
$u->{$o} = $z;
}
my @j = split(/,/, $defs->{$bt});
my @t = ();
foreach my $j (@j) {
push @t, join("", $j, "=", '"', $u->{$j}, '"') if defined $u->{$j};
}
my $jt = join(" ", @t);
my $text = join("", "<", $bt, " ", $jt, ">");
return $text;
}
###
### split_html_webtags_line
###
### Splits a line from the HTML to webtags configuration file
###
sub split_html_webtags_line {
my ($line) = @_;
$line =~ s/\s+$//;
my ($command, $tag, $rest) = split(/\s+/, $line, 3);
my @r = split(/\s+/, $rest);
my $ending = pop @r;
return ($command, $tag, join(" ", @r), $ending);
}
###
### find_within_array
###
### Finds the position of the first matching element of an array
###
sub find_within_array {
my ($pattern, $array) = @_;
my $counter = 0;
foreach my $element (@{ $array }) {
return $counter if $element =~ /$pattern/i;
$counter++;
}
return undef;
}
1;