home *** CD-ROM | disk | FTP | other *** search
/ rtsi.com / 2014.01.www.rtsi.com.tar / www.rtsi.com / OS9 / FAQ / discus_admin_1357211388 / source / fcn-html.pl < prev    next >
Text File  |  2009-11-06  |  7KB  |  245 lines
  1. # FILE: fcn-html.pl
  2. # DESCRIPTION: HTML to formatting tags converstion; auto-activations
  3. #-------------------------------------------------------------------------------
  4. # DISCUS COPYRIGHT NOTICE
  5. #
  6. # Discus is copyright (c) 2002 by DiscusWare, LLC, all rights reserved.
  7. # The use of Discus is governed by the Discus License Agreement which is
  8. # available from the Discus WWW site at:
  9. #    http://www.discusware.com/discus/license
  10. #
  11. # Pursuant to the Discus License Agreement, this copyright notice may not be
  12. # removed or altered in any way.
  13. #-------------------------------------------------------------------------------
  14.  
  15. use strict;
  16. use vars qw($GLOBAL_OPTIONS $DCONF $PARAMS);
  17.  
  18. ###
  19. ### activate_links
  20. ###
  21. ### Converts URLs and e-mail addresses to links
  22. ###
  23.  
  24. sub activate_links {
  25.     my ($text, $FORMref, $noactivate_tags) = @_;
  26.     return $text if $FORMref->{active_links} == 0 && $FORMref->{active_links_a};
  27.     return $text if ! $FORMref->{active_links_a} && $text =~ /\\\S+\{.+\}/s;
  28.     my $default_open_tag = ('topurl', 'newurl', 'link')[0+$GLOBAL_OPTIONS->{default_autoactivate_frameset}];
  29.     if (! defined $PARAMS->{webtags_no_active}) {
  30.         my $wtc = defined $PARAMS->{webtags_conf} ? $PARAMS->{webtags_conf} : readfile("$DCONF->{admin_dir}/webtags.conf", "read_tags", { no_lock => 1, no_unlock => 1 });
  31.         $PARAMS->{webtags_conf} = $wtc;
  32.         foreach $_ (@{$wtc}) {
  33.             next if /^#/ || ! /\S/;
  34.             $_ = trim($_);
  35.             if (my ($evaltag, $cont, $code, $act) = m|^(\*?)([cC0-9sSmM]\*?)\s*(\S+)\s*(.*)|) {
  36.                 $code = char_convert(lc($code));
  37.                 if ($cont =~ /\*$/) {
  38.                     $PARAMS->{webtags_no_active}->{$code} = 1;
  39.                 }
  40.             }
  41.         }
  42.         $PARAMS->{webtags_no_active}->{form} = 1;
  43.     }
  44.     my $noactive_tags = "imagelink|topurl|link|newurl|mail|";
  45.     $noactive_tags .= join("|", keys %{$PARAMS->{webtags_no_active}}) if ref $PARAMS->{webtags_no_active} eq 'HASH';
  46.     $noactive_tags =~ s/\|$//;
  47.     my @u = split(/\\(?:$noactive_tags)\{.*?\}/io, $text);
  48.     my @v = (); while ($text =~ /\\($noactive_tags)\{.*?\}/gio) { push @v, $&; };
  49.  
  50. #     New code to prevent interference with tags that take URLs:
  51. #    my @u = split (/\\\S+\{(?:[^\s\}\\]|\\,)+,/o, $text);
  52. #    my @v = (); while ($text =~ /(\\\S+\{(?:[^\s\}\\]|\\,)+,)/og) { push @v, $1; }
  53.     
  54.     foreach my $u (@u) {
  55.         my $after = $u; my $m = "";
  56. W1:        while ($after =~ m%(https?://|www\.)([\w\-\.\+/~\%\?\&\=\:\,\#\^]+)%i) {
  57.             $after = $'; my ($before, $one, $two) = ($`, $1, $2);
  58.             if ($two !~ /^([\w\-]+)\.([\w\-]+)/) {
  59.                 $m .= join("", $before, $one, $two);
  60.                 next W1;
  61.             }            
  62.             my $url = join("", $one, $two);
  63.             $one = join("", "http://", $one) if $one !~ /^https?:/i;
  64.             my $url_link = join("", $one, $two);
  65.             if ($url =~ m|([\.\:\;\,])$|) {
  66.                 $url = $`; $after = "$1$after";
  67.             }
  68.             $url_link = $` if $url_link =~ m|([\.\:\;\,])$|;
  69.             $url_link =~ s/,(.)/\%2C$1/g;
  70.             $m .= join("", $before, "\\$default_open_tag\{$url_link,$url}");
  71.         }
  72.         $u = join("", $m, $after);
  73.         $after = $u; $m = "";
  74. W2:        while ($after =~ m%(ftp?://|ftp\.)([\w\-\.\+/~\%\?\&\=\:\,]+)%i) {
  75.             $after = $'; my ($before, $one, $two) = ($`, $1, $2);
  76.             if ($two !~ /^([\w\-]+)\.([\w\-]+)/) {
  77.                 $m .= join("", $before, $one, $two);
  78.                 next W2;
  79.             }            
  80.             my $url = join("", $one, $two);
  81.             $one = join("", "ftp://", $one) if $one !~ /^ftp:/i;
  82.             my $url_link = join("", $one, $two);
  83.             if ($url =~ m|([\.\:\;\,])$|) {
  84.                 $url = $`; $after = "$1$after";
  85.             }
  86.             $url_link = $` if $url_link =~ m|([\.\:\;\,])$|;
  87.             $url_link =~ s/,(.)/\%2C$1/g;
  88.             $m .= join("", $before, "\\$default_open_tag\{$url_link,$url}");
  89.         }
  90.         $u = join("", $m, $after);
  91.         $after = $u; $m = "";
  92. W3:        while ($after =~ m|([\w\-\+\.]+)\@([\w\-\+\.]+)|i) {
  93.             $after = $';
  94.             my ($url, $before) = (join("", $1, "\@", $2), $`);
  95.             if ($url =~ m|([\.\:\;\,])$|) {
  96.                 $url = $`; $after = "$1$after";
  97.             }
  98.             my $url_link = $url;
  99.             $url_link = $` if $url_link =~ m|([\.\:\;\,])$|;
  100.             $url_link =~ s/,(.)/\%2C$1/g;
  101.             $m .= join("", $before, "\\mail\{$url_link,$url}");
  102.         }
  103.         $u = join("", $m, $after);
  104.         $after = $u; $m = "";
  105.     }
  106.     foreach my $v (@v) {
  107.         if ($v =~ /^\\(\w+)\{(.*?),(.*)\}/) {
  108.             my ($tag, $url, $aft) = ($1, $2, $3);
  109.             if ($url =~ /^([\w\-]+)\.([\w\-]+)\.([\w\-]+)/) {
  110.                 $url = join("", "http://", $url);
  111.             }
  112.             $v = join("", "\\", $tag, '{', $url, ",", $aft, "}");
  113.         }
  114.     }    
  115.     my $message = "";
  116.     while (scalar(@u) + scalar(@v)) {
  117.         $message .= shift @u; $message .= shift @v;
  118.     }
  119.     return $message;    
  120. }
  121.  
  122. ###
  123. ### html_to_webtags
  124. ###
  125. ### Converts incoming unvalidated user HTML into Discus formatting tags
  126. ###
  127.  
  128. sub html_to_webtags {
  129.     my ($text, $FORMref) = @_;
  130.     return $text if $FORMref->{html} == 0 && $FORMref->{html_a};
  131.     return $text if ! $FORMref->{html_a} && $text =~ /\\\S+\{.+\}/s;
  132.     my $u = readfile("$DCONF->{admin_dir}/htmlconvert.conf", "html_to_webtags", { no_lock => 1, no_unlock => 1});
  133.     my @X = grep(/\S/, grep(!/^\s*#/, @{ $u }));
  134.     my @j = (); my $defs = {};
  135.     study $text;
  136.     foreach my $line (@X) {
  137.         my ($cmd, $tag, $start, $end) = split_html_webtags_line($line);
  138.         if ($cmd =~ /o/i) {
  139.             $defs->{$start} = $end;
  140.         } else {
  141.             next if $text !~ /$start/i;
  142.             next if $text !~ /$end/i;
  143.             $tag =~ s/\[\\n\]/\n/g;
  144.             push @j, { start => $start, end => $end, tag => $tag };            
  145.         }        
  146.     }    
  147.     my @u = split(/<.*?>/, $text);
  148.     my @v = (); while ($text =~ /(<.*?>)/g) { push @v, reorder_tag_arguments($1, $defs); }
  149.     $text = "";
  150.     while (scalar(@u) + scalar(@v)) {
  151.         $text .= shift @u; $text .= shift @v;
  152.     }
  153.     foreach my $j (@j) {
  154.         if ($text =~ /$j->{start}/) {
  155.             while (my @r = $text =~ /(.*)$j->{start}(.*?)$j->{end}/is) {
  156.                 my $after = $'; my $before = $`;
  157.                 my $one = shift @r;
  158.                 my @a = splice @r, 0, scalar(@r)-1;
  159.                 my $txt = shift @r;
  160.                 my $ttg = $j->{tag};
  161.                 $ttg =~ s/\$(\d+)/$a[$1-1]/ge;
  162.                 $ttg =~ s/\$\'/$txt/g;
  163.                 $text = join("", $before, $one, $ttg, $after);
  164.             }
  165.         }
  166.     }
  167.     return $text;
  168. }
  169.  
  170. ###
  171. ### give_base_tag
  172. ###
  173. ### Determines which tag is being passed
  174. ###
  175.  
  176. sub give_base_tag {
  177.     my ($text) = @_;    
  178.     if ($text =~ /<\s*([^\s>]+)/) {
  179.         my $o = case_lower($1);
  180.         return $o;
  181.     }
  182.     return undef;    
  183. }
  184.  
  185. ###
  186. ### reorder_tag_arguments
  187. ###
  188. ### Reorders arguments within a tag, deletes superfluous arguments
  189. ###
  190.  
  191. sub reorder_tag_arguments {
  192.     my ($usertag, $defs) = @_;
  193.     my $bt = case_lower(give_base_tag($usertag));
  194.     return join($bt, "<", ">") if ! defined $bt || ! defined $defs->{$bt};
  195.     my $u = {};
  196.     while ($usertag =~ /\s(\w+)\s*=\s*['"]?(.*?)['"\s>]/g) {
  197.         my $o = case_lower($1);
  198.         my $z = $2;
  199.         $u->{$o} = $z;
  200.     }    
  201.     my @j = split(/,/, $defs->{$bt});
  202.     my @t = ();
  203.     foreach my $j (@j) {
  204.         push @t, join("", $j, "=", '"', $u->{$j}, '"') if defined $u->{$j};
  205.     }
  206.     my $jt = join(" ", @t);
  207.     my $text = join("", "<", $bt, " ", $jt, ">");
  208.     return $text;        
  209. }
  210.  
  211. ###
  212. ### split_html_webtags_line
  213. ###
  214. ### Splits a line from the HTML to webtags configuration file
  215. ###
  216.  
  217. sub split_html_webtags_line {
  218.     my ($line) = @_;
  219.     $line =~ s/\s+$//;
  220.     my ($command, $tag, $rest) = split(/\s+/, $line, 3);
  221.     my @r = split(/\s+/, $rest);
  222.     my $ending = pop @r;
  223.     return ($command, $tag, join(" ", @r), $ending);    
  224. }
  225.  
  226.  
  227. ###
  228. ### find_within_array
  229. ###
  230. ### Finds the position of the first matching element of an array
  231. ###
  232.  
  233. sub find_within_array {
  234.     my ($pattern, $array) = @_;
  235.     my $counter = 0;
  236.     foreach my $element (@{ $array }) {
  237.         return $counter if $element =~ /$pattern/i;
  238.         $counter++;
  239.     }
  240.     return undef;
  241. }
  242.  
  243.  
  244. 1;
  245.