Utf-8 :scalar . + разбор Accept-Language:

#!perl
use strict;
use warnings;
#=========================
use utf8;
use open ':encoding(utf8)';
binmode(STDOUT, ":utf8");
# так вроде нормально с utf работают все print и open
use Data::Dumper;
 
print 'Content-type: text/html; charset=utf-8'.$/.$/;
 
# какие-то такие навверно бывают заголовки Accept-Language
my @ALs = (
    'en-ca,en;q=0.8,en-us;q=0.6,de-de;q=0.4,de;q=0.2',
    'ru-RU,ru;q=0.8,en-US;q=0.5,en;q=0.3',
    'en',
    'ru-RU',
    'zh, en-us; q=0.8, en; q=0.6'
    );
 
my $MyVars = ' ru en ';
 
# сначала как-то так думал нормально разбирает
#### my %ha = ($_ =~ /\G([a-z]{2})(?>[^;]*+;q=([.\d]++),?)?/g);
##### не вариант ... значения перезаписываются, хэш сортируется
for (@ALs){
    my @ha = ($_ =~ /\G([a-z]{2})(?>[^;]*+;q=([.\d]++),?)?/g);
    print '<xmp>'.$/. Dumper(\@ha) .'</xmp><hr/>'.$/;
}
# но потом попался где-то тот последний вариант Accept-Language ...
# И ещё такой попался перечень,
# из файлов Apache которые юзает httpd-multilang-errordoc.conf
my $MyVars2 = ' cs de en es fr ga it ja ko nl nb pl pt-br pt ro ru sr sv tr zh-cn zh-tw ';
# типо pt-br это не совсем pt, значить надо выбирать что-то такое ?
for (@ALs){
    my @ha = (/([a-z]{2}(?>-[a-z]{2})?)/ig);
    print '<hr/><hr/><xmp>'.$/. lc Dumper(\@ha) .'</xmp><hr/>'.$/;
}

my $txt = '
    관리 작업이나 용량 문제로 서버가 잠시동안 요청을 처리할 수 없습니다.
    나중에 다시 시도해주시기 바랍니다.
    Сервер временно не имеет возможности обработать Ваш запрос
    по техническим причинам. Пожалуйста, повторите позже.
    由于服务器维护或负载问题，服务器暂时无法处理您的请求。请稍后重试。
';
my $BUFFER = '';
open my $FH, '+>', \$BUFFER; # или '+>:scalar', вроде без разницы
# или я уже перепробывал все возможные :raw :utf8 :unix :encoding....
# или я чего-то не догоняю... в итоге например такое:
while ($txt =~ /.++\v++/gp){
    print $FH ${^MATCH};
}
# 1. просто вывод $BUFFER
print '<hr/><hr/><hr/>1:<xmp>'. $BUFFER .'</xmp><hr/>'.$/;
# 2. вывод $BUFFER после seek
seek $FH ,0,0;
print '2:<xmp>'. $BUFFER .'</xmp><hr/>'.$/;
# 3. вывод $BUFFER чтением $FH
print '3:<xmp>';
print for <$FH>;
print '</xmp>';
close $FH;

my $txt = "
        \x{AD00}\x{B9AC} \x{C791}\x{C5C5}\x{C774}\x{B098} \x{C6A9}\x{B7C9} \x{BB38}\x{C81C}\x{B85C} \x{C11C}\x{BC84}\x{AC00} \x{C7A0}\x{C2DC}\x{B3D9}\x{C548} \x{C694}\x{CCAD}\x{C744} \x{CC98}\x{B9AC}\x{D560} \x{C218} \x{C5C6}\x{C2B5}\x{B2C8}\x{B2E4}.
    \x{B098}\x{C911}\x{C5D0} \x{B2E4}\x{C2DC} \x{C2DC}\x{B3C4}\x{D574}\x{C8FC}\x{C2DC}\x{AE30} \x{BC14}\x{B78D}\x{B2C8}\x{B2E4}.
    Сервер временно не имеет возможности обработать Ваш запрос
    по техническим причинам. Пожалуйста, повторите позже.
    \x{7531}\x{4E8E}\x{670D}\x{52A1}\x{5668}\x{7EF4}\x{62A4}\x{6216}\x{8D1F}\x{8F7D}\x{95EE}\x{9898}\x{FF0C}\x{670D}\x{52A1}\x{5668}\x{6682}\x{65F6}\x{65E0}\x{6CD5}\x{5904}\x{7406}\x{60A8}\x{7684}\x{8BF7}\x{6C42}\x{3002}\x{8BF7}\x{7A0D}\x{540E}\x{91CD}\x{8BD5}\x{3002}
";

#!perl
use strict;
use warnings;
use utf8;
use open ':encoding(utf8)';
binmode(STDOUT, ":utf8");
use List::Util 'first'; # ( ,'uniq');
 
print 'Content-type: text/html; charset=utf-8'.$/.$/;
 
sub check_lang_list ($\@$) {
    my ($ALang, $LRef, $default) = @_;
    return $default unless defined $ALang;
    while ($ALang =~ /\b(([a-z]{2})(?>-[a-z]{2})?)\b(?>(?>\s*;\s*q=[.\d]++)?\s*,\s*\2\b)?/ig) {
        my @X = ($1,$2);
        my $M = (first { $_ eq $X[0] } @$LRef) // (first { $_ =~ /^$X[1]/ } @$LRef);
        return $M if ($M);
    }
    $default;
}
 
my @ALs = (
    'ru-RU,ru;q=0.8,en-US;q=0.5,en;q=0.3',
    'en-ca,en;q=0.8,en-us;q=0.6,de-de;q=0.4,de;q=0.2',
    'es',
    'ru-RU',
    'zh, en-us; q=0.8, en; q=0.6',
    'xx_yy',
);
my @MyVars2 = qw'cs de en es fr ga it ja ko nl nb pl pt-br pt ro ru sr sv tr zh-cn zh-tw';
 
print ''.(defined $_?$_:'undef').'==='.check_lang_list($_, @MyVars2, 'en').'<hr/>'.$/
        for @ALs;

use Data::Dumper;
use utf8;
use open ':encoding(utf8)';
binmode(STDOUT, ":utf8");
use Encode; 
 
open my $TFH, '<', $FTPL;
ShowTpl $TFH;
 
my %ERRS = (
      '400' => '/X/error/HTTP_BAD_REQUEST.html.var',
      '401' => '/X/error/HTTP_UNAUTHORIZED.html.var',
      '403' => '/X/error/HTTP_FORBIDDEN.html.var',
      '404' => '/X/error/HTTP_NOT_FOUND.html.var',
      '405' => '/X/error/HTTP_METHOD_NOT_ALLOWED.html.var',
      '408' => '/X/error/HTTP_REQUEST_TIME_OUT.html.var',
      '410' => '/X/error/HTTP_GONE.html.var',
      '411' => '/X/error/HTTP_LENGTH_REQUIRED.html.var',
      '412' => '/X/error/HTTP_PRECONDITION_FAILED.html.var',
      '413' => '/X/error/HTTP_REQUEST_ENTITY_TOO_LARGE.html.var',
      '414' => '/X/error/HTTP_REQUEST_URI_TOO_LARGE.html.var',
      '415' => '/X/error/HTTP_UNSUPPORTED_MEDIA_TYPE.html.var',
      
      '500' => '/X/error/HTTP_INTERNAL_SERVER_ERROR.html.var',
      '501' => '/X/error/HTTP_NOT_IMPLEMENTED.html.var',
      '502' => '/X/error/HTTP_BAD_GATEWAY.html.var',
      '503' => '/X/error/HTTP_SERVICE_UNAVAILABLE.html.var',
      '506' => '/X/error/HTTP_VARIANT_ALSO_VARIES.html.var'
);
 
#print '<xmp>'.$/. Dumper(\%ERRS) .'</xmp><hr/>'.$/;
#return;
 
print '<xmp>';
foreach (keys %ERRS) {
    my $key = $_;
    print $key .' === '. $ERRS{$key} .$/;
 
    open my $FH, '<', $ERRS{$key};
    read $FH, my $txt, (stat $ERRS{$key})[7];
    close $FH;
 
    my @poss = ();
    my $StrH;
 
    open $FH, '+>', $DATA.$R_MOD .'/tmp.txt';
#   open $FH, '+>', \$StrH; .............
 
    while($txt =~ /^Body:(-++([a-z]{2}(?>-[a-z]{2})?)-++)\s++((?>^(?!\1)\V*+\v*+)++)\1/gm){
        my $str = $3;
        push @poss, $2;
        push @poss, tell $FH;
        my $title = '';
        $str =~ s/<!--#set var="CONTENT_LANGUAGE" value="([^"]++)[^>]++>//;
        $str =~ s/<!--#set var="TITLE" value="([^"]++)[^>]++>/($title = $1), ''/e;
    $str =~ s/<!--#include [^>]++>//g;
    $str =~ s/^\h*+<!--#(else|endif) *-->/###$1/mg;
    $str =~ s/^\h*+<!--#if[^>]*? expr="(?:-n\s*+)?v\(([^\)]++)\)([^"]*+)"[^>]*+>/###if \$ENV{$1}$2/mg;
    $str =~ s/^(.*)<!--#echo[^>]*? var="([^"]++)"[^>]*+>(\V*+)/'$1'.\$ENV{'$2'} .'$3'/mg;
        print $FH $title .$/;
        print $FH $str .'==='.$/;
    }
    seek $FH,0,0;
 
    open my $FH2, '>', $DATA.$R_MOD .'/'. $key .'.txt';
    print $FH2 join(' ', @poss) .$/;
    print $FH2 $_ for(<$FH>);
    close $FH2;
    close $FH;
    @poss = ();
 
    $r->rflush;
}
print '</xmp>';
ShowTpl $TFH;
unlink $DATA.$R_MOD .'/tmp.txt';

#use Apache2::RequestRec ('headers_out');
#use Text::XSlate;
use strict;
use warnings;
#=========================
use utf8;
use open ':encoding(utf8)';
binmode(STDOUT, ":utf8");
use List::Util 'first'; # ( ,'uniq');
use List::Util 'first';
 
 
my @Ls = qw'cs de en es fr ga it ja ko nl nb pl pt-br pt ro ru sr sv tr zh-cn zh-tw';
my $NUMS = ' 400 401 403 404 405 408 410 411 412 413 414 415 500 501 502 503 506';
my $fh;
my $LANG;
my @ERRORS = ();
 
sub check_lang_list ($\@$) {
    my ($ALang, $LRef, $default) = @_;
    return $default unless defined $ALang;
    while ($ALang =~ /\b(([a-z]{2})(?>-[a-z]{2})?)\b(?>(?>\s*;\s*q=[.\d]++)?\s*,\s*\2\b)?/ig) {
        my @X = ($1,$2);
        my $M = (first { $_ eq $X[0] } @$LRef) // (first { $_ =~ /^$X[1]/ } @$LRef);
        return $M if ($M);
    }
    $default;
}
sub get_pos {
    my ($L, $txt) = @_;
    while($txt =~ /\G([-a-z]++)\s++(\d++)\s*+/g){
        return $2 if ($1 eq $L);
    }
    push @ERRORS, 'Can\'t find Lang';
    return 0;
}
 
sub Show_file (\$) {
    my $rFH = shift;
    my $F = 0;
    while(readline $$rFH){
#       print '<xmp>'. $_ .'</xmp><hr/>';
        last if /^===/;
        if (/^###(else|(?>end)?if)/p){
            if ($1 eq 'if') {
                $F = 1 unless( eval '('. ${^POSTMATCH} .')');
            }
#           elsif ($1 eq 'elseif') {}
            elsif ($1 eq 'endif') {
                $F = 0;
            }
            else{ #else
                $F ^= 1;
            }
            next;
        }
        elsif ($F){
            next;
        }
        if (/^'/){
            print eval $_;
        }
        else {
            print $_;
        }
    }
}
 
unless (defined $ENV{'HTTP_ACCEPT_LANGUAGE'} || $ENV{'HTTP_ACCEPT_LANGUAGE'} ne ''){
    $LANG = 'en';
}
else {
    $LANG = check_lang_list($ENV{'HTTP_ACCEPT_LANGUAGE'}, @Ls, 'en');
}
if (!$R_ID || index($NUMS, $R_ID)<0){
    $R_ID = '404';
}
$PG_T = $R_ID.' ';
my $F = $DATA .$R_MOD .'/'. $R_ID .'.txt'; ## file to output
    # $PG_T = 'About';
unless (open $fh, '<', $F) {
    push @ERRORS, 'Can\'t open file '.$F;
    $PG_T .= 'Error';
    $R_ID = '404';
}
 
open my $TFH, '<', $FTPL;
 
if($fh){
    my $pos = get_pos($LANG, scalar readline($fh));# fails without 'scalar'
    seek($fh, $pos, 1) if ($pos);
    $PG_T .= readline($fh);
 ShowTpl $TFH;
#   print '<h1>'. $PG_T .'</h1>'.$/;
    print '<p class="warn">';
    Show_file $fh;
    close $fh;
    print '</p>';
}
 
print '<div class="warn">'. $_ .'</div>'.$/ for @ERRORS;
ShowTpl $TFH;