view release on metacpan or  search on metacpan

lib/Aion/Format/Html.pm  view on Meta::CPAN

le => 8804,
# ≥	больше или равно = is greater or equal to	≥	≥
ge => 8805,
# ⊂	подмножество = is subset of	⊂	⊂
sub => 8834,
# ⊃	включает в себя = is superset of	⊃	⊃
sup => 8835,
# ⊄	не является подмножеством = is not subset of	⊄	⊄
nsub => 8836,
# ⊆	подмножество или эквивалентно = is subset of or equivalent to	⊆	⊆
sube => 8838,
# ⊇	включает в себя или эквивалентно = is superset of or equivalent to	⊇	⊇
supe => 8839,
# ⊕	плюс в круге = прямая сумма	⊕	⊕
oplus => 8853,
# ⊗	умножение [косым] крестом в круге = тензорное произведение	⊗	⊗
otimes => 8855,
# ⊥	up tack = ортогонально к = перпендикулярно	⊥	⊥
perp => 8869,
# â‹…	умножение точкой = скалярное произведение	⋅	⋅
sdot => 8901,
#
#
# Технические символы
# Символ	Назначение	Мнемоника	Код
#
# ⌈	левая скобка округления вверх = apl upstile	⌈	⌈
lceil => 8968,
# ⌉	правая скобка округления вверх	⌉	⌉
rceil => 8969,
# ⌊	левая скобка округления вниз = apl downstile	⌊	⌊
lfloor => 8970,
# ⌋	правая скобка округления вниз	⌋	⌋
rfloor => 8971,
# ⟨	угловая скобка влево = бра	⟨	〈
lang => 9001,
# ⟩	угловая скобка вправо = кет	⟩	〉
rang => 9002,
#
#
# Геометрические фигуры
# Символ	Назначение	Мнемоника	Код
#
# â—Š	ромб	◊	◊
loz => 9674,
#
#
# Различные символы
# Символ	Назначение	Мнемоника	Код
#
# â™ 	«пики» (карточная масть)	♠	♠
spades => 9824,
# ♣	«трефы» (карточная масть)	♣	♣
clubs => 9827,
# ♥	«червы» (карточная масть)	♥	♥
hearts => 9829,
# ♦	«бубны» (карточная масть)	♦	♦
diams => 9830,
);

sub _set(@) { +{ map { $_ => 1 } @_ } }

# Теги не имеющие закрывающего тега
our %SINGLE_TAG = %{ _set qw/area base br col embed hr img input link meta param source track wbr/ };

# <li> закрывается, если приходит </ol> или </ul>
our %TOP_CLOSE_TAG = (
	li 			=> _set(qw/ol ul/),
	caption 	=> _set(qw/table/),
	thead 		=> _set(qw/table/),
	tbody 		=> _set(qw/table/),
	tfoot 		=> _set(qw/table/),
	tr 			=> _set(qw/table thead tbody tfoot caption/),
	td 			=> _set(qw/table thead tbody tfoot caption/),
	th 			=> _set(qw/table thead tbody tfoot caption/),
	dt			=> _set(qw/dl/),
	dd			=> _set(qw/dl/),
	rt			=> _set(qw/ruby/),
	rp			=> _set(qw/ruby/),
	option 		=> _set(qw/optgroup select/),
	optgroup	=> _set(qw/select/),
);

# <tr> закрывает открытые <td> и <th> и <tr>
our %TOP_NEW_TAG = (
	head		=> _set(qw/body/),
	tr			=> _set(qw/tr thead tbody tfoot/),
	td			=> _set(qw/tr thead tbody tfoot td th/),
	th			=> _set(qw/tr thead tbody tfoot td th/),
	col			=> _set(qw/tr thead tbody tfoot td th colgroup/),
	colgroup	=> _set(qw/thead tbody tfoot caption colgroup/),
	caption		=> _set(qw/thead tbody tfoot caption/),
	thead		=> _set(qw/thead tbody tfoot caption/),
	tbody		=> _set(qw/thead tbody tfoot caption/),
	tfoot		=> _set(qw/thead tbody tfoot caption/),
	li			=> _set(qw/li/),
	dt			=> _set(qw/dt dd/),
	dd			=> _set(qw/dt dd/),
	rt			=> _set(qw/rt rp/),
	rp			=> _set(qw/rt rp/),
	option		=> _set(qw/option optgroup/),
	optgroup	=> _set(qw/optgroup/),
);

# Проверяет, что тег – одиночный
sub is_single_tag(;$) {
	exists $SINGLE_TAG{$_[0] // $_}
}

# Забрасывает тег в стек и возвращает закрытые
sub in_tag(\@$$) {
	my ($S, $tag, $atag) = @_;

	# Выбрасываем из стека предыдущий тег
	my @ret;
	push @ret, pop @$S while @$S and
		($TOP_NEW_TAG{ $S->[$#$S][0] })->{$tag};

	push @$S, [$tag, $atag] unless exists $SINGLE_TAG{$tag};

	@ret
}

# Выбрасывает тег из стека. Возвращает выдавленные им и выбрасывает исключение, если такого в стеке нет
sub out_tag(\@$) {
	my ($S, $tag) = @_;

	# Это одиночный тег - он не может быть закрывающим
	die "</$tag> is a single tag - it cannot be a closing tag" if exists $SINGLE_TAG{$tag};

	# закрываем предыдущий, если нужно
	my @ret;
	push @ret, pop @$S while @$S and
		($TOP_CLOSE_TAG{$S->[$#$S][0]})->{$tag};

	die "</$tag>, but stack is empty!" unless @$S;

	# тег равен закрывающему
	die "<$S->[$#$S][0]> in stack ne </$tag>!" if $S->[$#$S][0] ne $tag;

	push @ret, pop @$S;

	@ret
}


# Разбивает текст на страницы с учётом html-тегов
#
# 1. html-тег должен быть так же разнесён на страницы.
#
sub split_on_pages(@) {
	my ($html, $symbols_on_page, $by) = @_;

	# На какое расстояние страница может быть больше
	$by //= $symbols_on_page / 3 < 1000 ? int($symbols_on_page / 3): 1000;
	my $max = $symbols_on_page + $by;

	my @pages;		# массив страниц
	my @page;		# массив элементов текста и тегов текущей страницы
	my $c = 0;		# количество символов в текущей странице
	my $i_page = 0;	# индекс элемента @page который привысил размер страницы
	my $c_page = 0;	# количество символов @page по $i_page
	my $is_proposal = 0;			# В конце текущей страницы обнаружен конец предложения
	my $re_proposal = qr/[.?!…]/;
	my @S;			# массив открывающих тегов [tag, '<tag ...>']

	# Функция фиксирует страницу и сбрасывает счётчики
	my $make_page = sub {
		push @pages, join "", @page, map { "</$_->[0]>" } reverse @S;
		$i_page = $c = $is_proposal = 0;
		@page = map $_->[1], @S;
	};
	
	for(grep length, split m{(
		<[a-z] [^<>]* >
		| </ \s* [a-z]\w* \s* >
		| &(?: [a-z]\w* | \# \d+ | \#x[0-9a-f]+ ) ;?
		| \n 		# Абзац
		| $re_proposal+	# Предложение
		| \b		# Слово
	)}xiu, $html) {

		if(/^&/) {$c++} 	# html-символ
		elsif(/^<\/\s*([a-z]\w*)/) { # закрывающий тег
			my $tag = lc $1;
			eval { out_tag @S, $tag };
			next if $@;
			# </p> превращаем в <p></p>
			$_ = "<p></p>" if $tag eq "p";
		}
		elsif(/^<([a-z]\w*)/) { in_tag @S, lc $1, $_ }	# тег
		else {$c += length}	# текст

		push @page, $_; # накапливаем символы в массиве @page

		next if $c < $symbols_on_page;	# страницу не набрали - тогда на next

		$c_page = $c, $i_page = @page if !$i_page;

		# Просматриваем вперёд пока не найдём границу или не достигнем ограничения
		if(/^\n/) { $make_page->() } 	# Абзац
		elsif(!$is_proposal && /^$re_proposal/) { $i_page = @page; $c_page = $c; $is_proposal = 1 }
		elsif($c >= $max) {
			# Если следующий за предложением или словом элемент - пробелы, то добавляем их к странице
			$c_page -= length $page[$i_page++] if $page[$i_page] =~ /^\s/;
			my @x = splice @page, $i_page;
			$make_page->();
			push @page, @x;
			$c -= $c_page;
		}
	}

	$make_page->() if @page;

	# Если размер последней страницы меньше чем 2/3, то добавляем её к предпоследней
	$pages[$#pages - 1] .= pop @pages if @pages > 1 and length($pages[$#pages]) < $symbols_on_page * 2 / 3;

	#my $len = 0; $len += length for @pages;
	#die "Суммарный размер страниц не изменился: " . length($html) . " == $len pages=" . @pages . " ->\n\n$html" if $len == length $html;

	my ($end1) = $html =~ m!([^<>\s]{1,13})\s*(</?\w[^<>]*>\s*)*$!a;
	my ($end2) = $pages[$#pages] =~ m!([^<>\s]{1,13})\s*(</?\w[^<>]*>\s*)*$!a;
	die "Концы текста и последней страницы не сходятся! `$end1` <> `$end2`" if $end1 ne $end2;

	return @pages;
}

our %TAG2SPACE = (
	"br" => "\n",
	"dd" => "\n  ",
	"table" => "\n",

lib/Aion/Format/Html.pm  view on Meta::CPAN

		exists $+{hex}? chr hex $+{hex}: ""
	};
	s{&(
		(?<word>\w+)
		|\#(?<num>\d+)
		|\#x(?<hex>[a-f\d]+)
	);?
	}{$ent->()}genix;

	my $pre;

	my $to = sub {
		my $s1 = $pre? $+{s1}: ($+{s1} eq ""? "": " ");
		
		my $x =
		exists $+{space}? ($pre? $+{space}: " "):
		exists $+{nbsp}? " ":
		exists $+{xhr}? $+{xhr}:
		exists $+{tag}? do {
			my $tag = lc $+{tag};
			$pre = 1 if $tag eq "pre";
			exists $+{close}? $WITH_CLOSE_TAG2SPACE{$tag}: $TAG2SPACE{$tag} 
		}:
		exists $+{ctag}? do {
			my $tag = lc $+{ctag};
			$pre = 0 if $tag eq "pre";
			
			$CLOSE_TAG2SPACE{$tag}
		}:
		"";
		
		my $s2 = $pre? $+{s2}: ($+{s2} eq "" || $s1? "": " ");
		
		$x =~ /\n/ ? $x: join "", $s1, $x, $s2
	};

	s{
		(?<s1> \s*) (
		
			  <(script|style|template)\b [^<>]*> .*? </ \g1 \s* >
			| <xhr \b [^<>]*> (?<xhr> .*? ) </xhr \s* >
			| < (?<tag> [a-z]\w* ) [^<>]*? (?<close> / )? \s*>
			| </ (?<ctag> [a-z]\w* ) \s*>
			| <!--.*?-->
		
		) (?<s2> \s*)
		| (?<space> [\ \t\n\r\f]+)
		| (?<nbsp> \xa0)
	}{$to->()}genisx;

	$_
}

# Все, кроме запрещённых:
#  applet, script, style, embed, object, param,
#  video, audio, source, track, frame, frameset, iframe, comment
#  html, head, body, title, meta, base, basefont, bgsound, link
#  form, keygen, output, textarea, select, option, optgroup, legend, label, input
#  plaintext, xmp
# А так же удаляет атрибуты начинающиеся на "on", name, for, formaction и др..
my %SAFE_TAG = map {$_=>1} qw/
a
abbr
acronym
address

area
article
aside

b
bdi
bdo

blockquote
big

blink
br
button

canvas
caption
center
cite
code
col
colgroup
command

datalist
dd
del
details
dfn
dir
div
dl
dt

em

figcaption
figure
font
footer

h1
h2
h3
h4
h5
h6
header
hgroup
hr

i
img

ins
isindex

kbd
keygen

li

main
map
marquee
mark
menu

meter

nav
nobr
noembed
noframes
noscript

ol

p
pre
progress

q

rp
rt
ruby

s
samp
section
small
span
strike
strong
   sub
summary
sup

table
tbody
td
tfoot
th
thead
time

tr
tt

u
ul

var

wbr
/;

my %SAFE_ATTR = map {$_=>1} qw/
pubdate datetime
open optimum

dir lang language style tabindex title high low hreflang icon

max min

href media ping rel rev name type

class

src

alt crossorigin decoding height width importance  intrinsicsize loading sizes srcset

align border hspace vspace longdesc  axis  char charoff summary

colspan rowspan

border cite bgcolor color

coords
/;

# срезает у html-я опасные, а так же неведомые теги
sub safe_html($;$) {
	(local $_, my $link) = @_;

	my $f = sub {
		return "" if !exists $SAFE_TAG{lc $2};
		return "</$2>" if $1 ne "";
		my $tag = $2;
		my $x = $3;
		my @attrs;
		while($x =~ /
			\b (?<attr> [a-z][a-z\d]*) ( \s*=\s* ( (?<quot> ") (?<val> [^"]*)" | (?<quot> ') (?<val> [^']*)' | (?<val> \S*) ) )?
		/gixn) {
			push @attrs, $+{val} eq ""? " $+{attr}"
				: join "", " ", $+{attr}, "=", $+{quot},
					lc $+{attr} ~~ [qw/src href/]
						? Aion::Format::Url::normalize_url($+{val}, $link)
						: $+{val},
					$+{quot}
				if exists $SAFE_ATTR{lc $+{attr}};
		}

		push @attrs, " target=_blank" if lc $tag eq "a";

		"<$tag@attrs>"
	};

	s{<(/\s*)?([a-z][a-z\d:-]*)([^<>]*)>|<!--(?:.*?)-->}{ $f->() }igse;

	$_
}

1;

__END__