[技术讨论] 代码高亮 以及 Markdown 风格转 BBCode

              
http://codepad.org/
http://hilite.me/
https://tohtml.com/

Highlight Code Converter
参考7楼: highligh.exe 的使用示例

=info
    Markdown 部分格式转 BBCode + 代码块着色
    523066680@163.com / Code-By.Org
    2017-05

    V2.0 更新循环方案
=cut

use strict;
use Encode;
use IO::Handle(1);
STDOUT->autoflush(1);

our $highlight = 'D:/Lib/highlight-3.36-x64/highlight.exe';
my $file = encode('gbk', decode('utf8', "D:/Sync/Perl/教学翻译、整理/Perl One-Liners.md"));
#my $file = encode('gbk', decode('utf8', "sample.md"));

my @arr;
load($file, \@arr);

our @sizes = ( 2,3,4,5,6,7,8 );   #标题字体大小
reset_sizes( \@sizes, \@arr );   #根据实际层级重设列表
format_bbcode(\@arr);            #转论坛格式

my $all = join("\n", @arr);
our $table = '[list][table=60%, #f8f8f8][tr][td][font=consolas][size=2]';
our $table_tail = '[/size][/font][/b][/td][/tr][/table][/list]';
format_codeblock(\$all);

format_inline(\$all);

#bathome 的缩进不够明显，加倍
$all=~s/(\[list\])/$1$1/g;
$all=~s/(\[\/list\])/$1$1/g;

# table 后面不需要再换行
$all=~s{(\Q[/table]\E.*?\n)\n}{$1}sgi;

print encode('gbk', decode("utf8", $all));

sub format_bbcode
{
    my $arr = shift;
    my $prev;
    my $curv;
    my $crlf;
    my $size;

    for my $i ( 0 .. $#$arr )
    {
        $arr->[$i] =~s/(\r?\n)$//;
        $crlf = $1;
        if ( $arr->[$i]=~s/^(#+)// )
        {
            $curv = length($1);
            $size = $sizes[$curv-1]; #下标从 0 开始
            $arr->[$i] = "[size=$size][b]" .$arr->[$i] ."[/b][/size]";
            $arr->[$i] .= "[list]";

            if ( $prev )
            {
                if ( $curv <= $prev )
                {
                    $arr->[$i] = "[/list]"x($prev - $curv + 1) .$arr->[$i];
                }
                elsif ( $curv > $prev ) { }
            }

            $prev = $curv;
        }

        #遇到下一个标题时添加换行
        if ( $i < $#$arr 
            and $arr->[$i+1]=~/^\#/ 
            and ($arr->[$i] ne "") )
        {
            $arr->[$i] .= "\n";
        }

        #单行代码和代码块前面补充空行
        if ( ($i > 0)
            and ($arr->[$i] =~/^\s*`/)
            and ($arr->[$i-1] ne "")
            and (not $arr->[$i-1]=~/\n$/) 
            and (not $arr->[$i-1]=~/\[list\]/) 
            )
        {
            $arr->[$i-1] .= "\n";
        }

        format_inline( \$arr->[$i] );
        format_else(\$arr->[$i]);
    }

    #缩进结束
    $arr->[-1] .= '[/list]'x$prev if ( $prev > 0 );
}

sub format_codeblock
{
    our $highlight;
    my $all = shift;
    my $bbcode;

    while ($$all =~/```(\w+)?\r?\n(.*?)\r?\n```/s)
    {
        writeFile( "temp.txt", \$2 );
        if (defined $1)
        { `$highlight -K3 -S$1 -OBBCode --no-trailing-nl -ssourceforge ./temp.txt -o bbcode.txt`; }
        else
        { `$highlight -K3 -OBBCode --no-trailing-nl -ssourceforge ./temp.txt -o bbcode.txt`; }
        read_slurp( "bbcode.txt", \$bbcode );

        $bbcode = $table .'[font=consolas]' .$bbcode .'[/font]' .$table_tail;
        $$all =~s/```(\w+)?\r?\n(.*?)```/$bbcode/s;
    }
}

sub format_inline
{
    our $highlight;
    my $line = shift;
    my ($head, $tail ) = ('[font=consolas][b]', '[/b][/font]');
    my $inline_code;

    if ($$line=~/^\s*`[^"]+("|')(.+)("|')/)
    {
        writeFile( "temp.txt", \$2 );
        `$highlight -K3 -Sperl -OBBCode --no-trailing-nl -ssourceforge ./temp.txt -o bbcode.txt`;
        read_slurp( "bbcode.txt", \$inline_code );
        $$line=~s/^\s*`([^"]+)("|')(.+)("|')(.*)`/$head$1$2${inline_code}$4$5${tail}/;
    }
}

sub format_else
{
    my $line = shift;

    #粗体
    $$line=~s/\*{2}(.*?)\*{2}/\[b\]$1\[\/b\]/g;
    #斜体
    $$line=~s/\*(.*?)\*/\[i\]$1\[\/i\]/g;
    #链接
    $$line=~s/\[([^\]]+)\]\((.*?)\)/\[url=$2\]$1\[\/url\]/g;

}

sub reset_sizes
{
    my ($sizes, $arr) = @_;
    my $max = 0;
    grep { /^(#+)/; $max = length($1) if (length($1) > $max) } @$arr;
    @$sizes = reverse @{$sizes}[ 0 .. $max-1 ];
}

sub writeFile
{
    my ($f, $ref) = @_;
    open WRT, ">:raw", $f or warn "$!";
    print WRT $$ref;
    close WRT;
}

sub read_slurp
{
    my ($f, $ref) = @_;
    local $/ = undef;
    open READ,"<:raw:crlf", $f or warn "$!";
    $$ref = <READ>;
    close READ;
}

sub load
{
    my ($f, $ref) = @_;
    open READ,"<:raw", $f or warn "$!";
    @$ref = <READ>;
    close READ;
}
复制代码