Aion-Format

 view release on metacpan or  search on metacpan

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

	#show_refcount => 1,
	#show_memsize => 1,
	caller_info => 1,
	output => 'stdout',
	#unicode_charnames => 1,
};

#@category Ловушки

# Ловушка для STDERR
sub trapperr(&) {
	my $sub = shift;
	local *STDERR;
	open STDERR, '>:utf8', \my $f;
	$sub->();
	close STDERR;
	$f
}

# Ловушка для STDOUT
sub trappout(&) {
	my $sub = shift;
	local *STDOUT;
	open STDOUT, '>:utf8', \my $f;
	$sub->();
	close STDOUT;
	$f
}

#@category Цвет

# Колоризирует текст escape-последовательностями: coloring("#{BOLD RED}ya#{}100!#RESET"), а затем - заменяет формат sprintf-ом
sub coloring(@) {
	my $s = shift;
	$s =~ s!#\{(?<x>[\w \t]*)\}|#(?<x>\w+)!
		my $x = $+{x};
		$x = "RESET" if $x ~~ [qw/r R/];
		Term::ANSIColor::color($x)
	!nge;
	sprintf $s, @_
}

# Печатает в STDOUT вывод coloring
sub printcolor(@) {
	print coloring @_
}

# Печатает в STDERR вывод coloring
sub warncolor(@) {
	print STDERR coloring @_
}

# Для крона: Пишет в STDOUT
sub accesslog(@) {
	print "[", POSIX::strftime("%F %T", localtime), "] ", coloring @_;
}

# Для крона: Пишет в STDIN
sub errorlog(@) {
	print STDERR "[", POSIX::strftime("%F %T", localtime), "] ", coloring @_;
}


#@category Преобразования

# Проводит соответствия
#
# matches "...", qr/.../ => sub {...}, ...
#
sub matches($@) {
	my $s = shift;
	my $i = 0;
	my $re = join "\n| ", map { $i++ % 2 == 0? "(?<I$i> $_ )": () } @_;
	my $arg = \@_;
	my $fn = sub {
		for my $k (keys %+) {
			return $arg->[$k]->() if do { $k =~ /^I(\d+)\z/ and $k = $1 }
		}
	};

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

	а a  и i  п p  ц c	э eh
	б b  й y  р r  ч ch   ю ju
	в v  к k  с s  ш sh   я ja
	г g  л l  т t  щ sch
	д d  м m  у u  ъ qh
	е e  н n  ф f  ы y
	ё jo о o  х kh ь q
	ж zh	   
	з z
/;
sub transliterate($) {
	my ($s) = @_;
	$s =~ s/[а-яё]/lc($&) eq $&? $TRANS{$&}: ucfirst $TRANS{lc $&}/gier;
}

# Транслитетрирует текст, оставляя только латинские буквы и тире
sub trans($) {
	my ($s) = @_;
	$s = transliterate $s;
	$s =~ s{[-\s_]+}{-}g;
	$s =~ s![^a-z-]!!gi;
	$s =~ s!^-*(.*?)-*\z!$1!;
	lc $s
}

#@category Строки

# Преобразует в строку perl
sub to_str(;$) {
	my ($s) = @_ == 0? $_: @_;
	$s =~ s/[\\']/\\$&/g;
	$s =~ s/^(.*)\z/'$1'/s;
	$s
}

# Преобразует из строки perl
sub from_str(;$) {
	my ($s) = @_ == 0? $_: @_;
	$s =~ s/^'(.*)'\z/$1/s;
	$s =~ s/\\([\\'])/$1/g;
	$s
}

# Упрощённый язык регулярок
sub nous($) {
	my ($templates) = @_;
	my $x = join "|", map {
		matches $_,
		# Срезаем все пробелы с конца:
		qr!\s*$! => sub {},
		# Срезаем все начальные строки:
		qr!^([ \t]*\n)*! => sub {},
		# С начала каждой строки 4 пробела или 0-3 пробела и табуляция:
		qr!^( {4}| {0,3}\t)!m => sub {},
		# Пробелы в конце строки и пробельные строки затем заменяем на \s*

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

		qr!\)\)! => sub { ")" },
		qr!\|\|! => sub { "|" },
		# Остальное - эскейпим:
		qr!.*?! => sub { quotemeta $& },
	} @$templates;
	
	qr/$x/xsmn
}

# формирует человекочитабельный интервал
sub sinterval($) {
	my ($interval) = @_;

	if(0 == int $interval) {
		return sprintf "%.6f mks", $interval*1000_000 if 0 == int($interval*1000_000);
		return sprintf "%.7f ms", $interval*1000 if 0 == int($interval*1000);
		return sprintf "%.8f s", $interval;
	}

	my $hours = int($interval / (60*60));
	my $minutes = int(($interval - $hours*60*60) / 60);

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

#@category Цифры

# переводит в римскую систему счисления
# N - ноль
# Через каждую 1000 ставится пробел (разделитель разрядов)
our @RIM_CIF = (
	[ '', 'I', 'II', 'III', 'IV', 'V', 'VI', 'VII', 'VIII', 'IX' ],
	[ '', 'X', 'XX', 'XXX', 'XL', 'L', 'LX', 'LXX', 'LXXX', 'XC' ],
	[ '', 'C', 'CC', 'CCC', 'CD', 'D', 'DC', 'DCC', 'DCCC', 'CM' ]
);
sub rim($) {
	my ($a) = @_;
	use bigint; $a+=0;
	my $s;
	for ( ; $a != 0 ; $a = int( $a / 1000 ) ) {
		my $v = $a % 1000;
		if ( $v == 0 ) {
			$s = "M $s";
		}
		else {
			my $d;

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

our $CIF = join "", "0".."9", "A".."Z", "a".."z", "_-", # 64 символа для 64-ричной системы счисления
	(map chr, ord "А" .. ord "Я"), "ЁЂЃЉЊЌЋЏЎЈҐЄЇІЅ",
	(map chr, ord "а" .. ord "я"), "ёђѓљњќћџўјґєїіѕ",
	"‚„…†‡€‰‹‘’“”•–—™›¤¦§©«¬­®°±µ¶·№»",	do { no utf8; chr 0xa0 }, # небуквенные символы из cp1251
	"!\"#\$%&'()*+,./:;<=>?\@[\\]^`{|}~", # символы пунктуации ASCII
	" ", # пробел
	(map chr, 0 .. 0x1F, 0x7F), # управляющие символы ASCII
	# символ 152 (0x98) в cp1251 отсутствует.
;
# Переводит натуральное число в заданную систему счисления
sub to_radix($;$) {
	use bigint;
	my ($n, $radix) = @_;
	$radix //= 64;
	die "to_radix: The number system $radix is too large. Use NS before " . (1 + length $CIF) if $radix > length $CIF;
	$n+=0; $radix+=0;
	my $x = "";
	for(;;) {
		my $cif_idx = $n % $radix;
		my $cif = substr $CIF, $cif_idx, 1;
		$x =~ s/^/$cif/;
		last unless $n = int($n / $radix);
	}
	return $x;
}

# Парсит натуральное число в указанной системе счисления
sub from_radix(@) {
	use bigint;
	my ($s, $radix) = @_;
	$radix //= 64;
	$radix+=0;
	die "from_radix: The number system $radix is too large. Use NS before " . (1 + length $CIF) if $radix > length $CIF;
	my $x = 0;
	for my $ch (split "", $s) {
		$x = $x*$radix + index $CIF, $ch;
	}
	return $x;
}

# Округляет до указанного разряда числа
sub round($;$) {
	my ($x, $dec) = @_;
	$dec //= 0;
	my $prec = 10**$dec;
	int($x*$prec + 0.5) / $prec
}


#@category Меры (measure)

# добавляет разделители между разрядами числа
sub num($) {
	my ($s) = @_;

	my $sep = " "; # Неразрывный пробел
	my $dec = ".";

	($s, $sep, $dec) = @$s == 2? @$s: (@$s, $dec) if ref $s;

	my ($x, $y) = split /\./, $s;
	$y = "$dec$y" if defined $y;

	$x = reverse $x;
	$x =~ s!\d{3}!$&$sep!g;
	$x =~ s!$sep([+-]?)$!$1!;
	reverse($x) . $y;
}

# Добавляет разряды чисел и добавляет единицу измерения
sub kb_size($) {
	my ($n) = @_;

	return num(round($n / 1024 / 1024 / 1024)) . "G" if $n >= 1024 * 1024 * 1024;
	return num(round($n / 1024 / 1024)) . "M" if $n >= 1024 * 1024;
	return num(round($n / 1024)) . "k" if $n >= 1024;

	return num(round($n)) . "b";
}

# Оставляет $n цифр до и после точки: 10.11 = 10, 0.00012 = 0.00012, 1.2345 = 1.2, если $n = 2
sub sround($;$) {
	my ($number, $digits) = @_;
	$digits //= 2;
	my $num = sprintf("%.100f", $number);
	$num =~ /^-?0?(\d*)\.(0*)[1-9]/;
	return "" . round($num, $digits + length $2) if length($1) == 0;
	my $k = $digits - length $1;
	return "" . round($num, $k < 0? 0: $k);
}

# Кибибайт
sub KiB() { 2**10 }

# Мебибайт
sub MiB() { 2**20 }

# Гибибайт
sub GiB() { 2**30 }

# Тебибайт
sub TiB() { 2**40 }

# Максимум в данных TinyText Марии
sub xxS { 255 }

# Максимум в данных Text Марии
sub xxR { 64*KiB-1 }

# Максимум в данных MediumText Марии
sub xxM { 16*MiB-1 }

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

	70 => "для 13 лет (7-й класс)",
	60 => "для 8-х и 9-х классов",
	50 => "для 10-х, 12-х классов",
	40 => "для студентов",
	30 => "для бакалавров",
	20 => "для магистров",
	10 => "для профессионалов",
	0 => "для академиков",
);

sub flesch_index_human($) {
	my ($flesch_index) = @_;
	$FLESCH_INDEX_NAMES{int($flesch_index / 10) * 10} // "несвязный русский текст"
}

1;

__END__

=encoding utf-8

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

# â™ 	«пики» (карточная масть)	♠	♠
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/),

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

	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};

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

	push @ret, pop @$S;

	@ret
}

=pod
Разбивает текст на страницы с учётом html-тегов

1. html-тег должен быть так же разнесён на страницы.
=cut
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 который привысил размер страницы

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

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*) ) )?

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

our @EXPORT = our @EXPORT_OK = grep {
    *{$Aion::Format::Json::{$_}}{CODE} && !/^(_|(NaN|import)\z)/n
} keys %Aion::Format::Json::;

#@category json

# Настраиваем json
our $JSON = JSON::XS->new->allow_nonref->indent(1)->space_after(1)->canonical(1);

# Ð’ json
sub to_json(;$) {
	$JSON->encode(@_ == 0? $_: @_)
}

# Из json
sub from_json(;$) {
	$JSON->decode(@_ == 0? $_: @_)
}

1;

__END__

=encoding utf-8

=head1 NAME

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

our @EXPORT = our @EXPORT_OK = grep {
    ref \$Aion::Format::Url::{$_} eq "GLOB"
        && *{$Aion::Format::Url::{$_}}{CODE} && !/^(_|(NaN|import)\z)/n
} keys %Aion::Format::Url::;


#@category escape url

use constant UNSAFE_RFC3986 => qr/[^A-Za-z0-9\-\._~]/;

sub to_url_param(;$) {
	my ($param) = @_ == 0? $_: @_;
	$param =~ s/${\ UNSAFE_RFC3986}/$& eq " "? "+": sprintf "%%%02X", ord $&/age;
	$param
}

sub _escape_url_params {
	my ($key, $param) = @_;

	!defined($param)? ():
	$param eq 1? $key:
	ref $param eq "HASH"? do {
		join "&", map _escape_url_params("${key}[$_]", $param->{$_}), sort keys %$param
	}:
	ref $param eq "ARRAY"? do {
		join "&", map _escape_url_params("${key}[]", $_), @$param
	}:
	join "", $key, "=", to_url_param $param
}

sub to_url_params(;$) {
	my ($param) = @_ == 0? $_: @_;

	if(ref $param eq "HASH") {
		join "&", map _escape_url_params($_, $param->{$_}), sort keys %$param
	}
	else {
		join "&", List::Util::pairmap { _escape_url_params($a, $b) } @$param
	}
}

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

		( \# (?<hash>  .*	   ) )?
	\z!xn;
	return %+;
}

# 1 - set / in each page, if it not file (*.*), or 0 - unset
use config DIR => 0;
use config ONPAGE => "off://off";

# Парсит и нормализует url
sub parse_url($;$$) {
	my ($link, $onpage, $dir) = @_;
	$onpage //= ONPAGE;
	$dir //= DIR;
	my $orig = $link;

	my %link = _parse_url $link;
	my %onpage = _parse_url $onpage;

	if(!exists $link{path}) {
		$link{path} = join "", $onpage{path}, $onpage{path} =~ m!/\z!? (): "/", $link{part};

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

		$link{dom},
		$link{path},
		length($link{query})? ("?", $link{query}): (),
		length($link{hash})? ("#", $link{hash}): (),
	;

	return \%link;
}

# Нормализует url
sub normalize_url($;$$) {
	parse_url($_[0], $_[1], $_[2])->{link}
}

1;

__END__

=encoding utf-8

=head1 NAME