# mdevSGML_sc ( ver 0.12 ) :
# This program compares two SGMLs and reports on the result.
#   Written by prepress-tips 2009.2.12 - 2009.3.9
#   Contact: prepress-tips@users.sourceforge.jp
# This program is under the same licensing terms as Perl
# ( the Artistic License 1.0 or the GNU GPL ).
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

# - 起動

    # 開始メッセージを表示する。
        msg( 'mdevSGML_sc ( ver 0.12 )');
        $fn, $fol;  { # 入力ファイル
            # 入力ファイル
                @ARGV > 0 || err( '  ファイルを指定してください。' );
                my $f = $ARGV[0];
                -f $f || err( '  ファイルがありません。' );
                $f =~ /^((?:\\|[\00-\x7f\xa0-\xdf]|..)*\\)([^\\]+\.sgml?)$/i ||
                    err( '  sgmlファイルを指定してください。' );
                ( $fol, $fn ) = ( $1, $2 );
                msg( "  $fn" );
        }
        $ofn;  { # 比較ファイル
            # 比較ファイル
                my $f = $fn; $f =~ s/\.sgm$/_old$&/i;
                -f $fol.$f || err( '  ファイルがありません。' );
                $ofn = $f;
                msg( "    vs  $ofn" );
        }
        $hfn;  { # 出力ファイル
            # 出力ファイル
                my $f = $fn; $f =~ s/\.sgm$/_cmp.htm/i;
                $hfn = $f;
        }
        $opt;  { # オプション
            # オプション
                $opt = @ARGV > 1 ? $ARGV[1] : "" ;
                $opt eq "" || msg( "  option : $opt" );
        }

=pod - 起動時オプション
        perl   mdevSGML_sc.pl   入力sgml   [dscf]
            d : デバグ用出力あり
            s : 相違箇所の前後のみ表示
            c : 赤・青反転
            f : 差分情報を含むsgmlを作成（ _diff.sgm ）
=cut

# - 入力ファイル・比較ファイル

    @sgm;  # 入力sgml 
    @old;  # 比較sgml 
    $dtd;  # dtd 

    { #+ 入力ファイル・比較ファイルを タグ＋テキスト の形に分ける。
        # 入力sgmlを読む。
            @sgm = getF( $fol.$fn );
        # dtd を調べる。
            $dtd = '';
            for( @sgm ) {
                /^<\!DOCTYPE\s/ || next;
                /^<!DOCTYPE MDEVICES SYSTEM "medical_device.dtd"/ && ( $dtd = 'mdev' );
                /^<!DOCTYPE PACKINS SYSTEM "package_insert.dtd"/ && ( $dtd = 'packins' );
                last;
            }
        # 入力sgml を タグ＋テキスト の形に分ける。
            sepTT(  \ @sgm );
        # 比較sgmlを読む。
            @old = getF( $fol.$ofn );
        # 比較sgml を タグ＋テキスト の形に分ける。
            sepTT(  \ @old );
    }

    sub sepTT { # ( buf )を タグ＋テキスト の形に分ける。 
        $in;  { # 処理の準備をする。
            # 処理の準備をする。
                $in = join '', @{$_[0]};
        }
        # タブと改行をエスケープする。
            $in =~ s/(\\)+[tn]/\\$&/g;
            $in =~ s/\t/\\t/g;
            $in =~ s/\x0d?\x0a/\\n/g;
        # 不要な改行を削除する。
            $in =~ s,>(\\n)+,>\\n,g;
            $in =~ s,(\\n)+\x0a,\x0a,g;
        # 半角＆をエスケープする。
            $in =~ s/\&/&amp;/g;
        # DOCTYPE宣言をエスケープする。
            while( $in =~ s/(<!DOCTYPE\s[^<>]*)<(![^>]*)>/$1&lt;$2&gt;/i ) {};
            $in =~ /<!DOCTYPE\s(?:.|\s)*?>/; my ( $p, $q, $r ) = ( $`, $&, $' );
            $q =~ s/&lt;((?:.|\s)*?)&gt;((?:\\n)*)/\x0a<$1>$2\x0a/g; $q =~ s/\x0a+/\x0a/g;
            $in = "$p$q$r";
        # タグ＋テキストの形に分ける。
            $in =~ s/<[^<>]*(?=<)/$&\t/g;
            $in =~ s/([^\x0a\t])(<)/$1\x0a$2/g;
            $in =~ s/\t//g;
        # 結果を保存する。
            @{$_[0]} = map do { [ $_ ] }, ( split "\x0a", $in );
    }

# - 比較ブロック

    @cmp;  # 比較結果 
    @cmp_out;  # 比較結果のデバグ出力 
    $dmax, $dsame, $dlen;  # 許容相違箇所数 と 最小比較長 
=pod 
        @cmp
            ( \@比較ブロック, ・・・ )
        @比較ブロック
            ( '比較状況', \@新文字列ブロック, \@旧文字列ブロック, ・・・ )
                '比較状況'は  'pass' 'near' 'ins' 'del'  処理が終われば 'verified'
        @文字列ブロック
            ( \@文字列, ・・・ )
                タグ＋テキスト の形に分ける。
        @文字列
            ( '文字列', ・・・ )
=cut

    { #+ 入力ファイル・比較ファイルを 比較ブロックに分け 照合する。
        @tags;  { # 主要なタグ 
            # dtd が 'mdev' ならば 主要なタグを 'mdevSGML_sc.txt' から読む。
                if( $dtd eq(  'mdev' ) ) { getF_tags(  'mdevSGML_sc.txt' ) }
            # dtd が 'packins' ならば 主要なタグを 'packinsSGML_sc.txt' から読む。
                if( $dtd eq(  'packins' ) ) { getF_tags(  'packinsSGML_sc.txt' ) }
            # 終了タグを追加する。
                my @t = @tags; @tags = (); my $lv = ''; my @lv = ();
                for( @t, '/ ' ) {
                    /\/\s+/ || next;
                    my ( $sp, $tag ) = ( $`, $' ); $sp =~ /^(　)*/ && ( $sp = $& );
                    $lv =~ /^$sp/ && ( $lv = pop @lv );
                    while( $lv =~ /^$sp　/ && @lv ) { $lv = pop @lv; push @tags, $lv; }
                    $lv = "$sp/$tag"; push @lv, $lv; push @tags, "$sp$tag";
                }
                pop @tags; # msg( '--- tags', @tags, '---' );
                @tags = map do { /^(　)*/; $'; }, @tags;
        }
        @pass;  { # 読み飛ばすタグ
            # 読み飛ばすタグ
                @pass = ( 'variablelabel', 'serialno', 'item', 'detail', 'Url' );
        }
        @atr;  { # 属性タグ
            # 属性タグ
                @atr = ( 'graphic', 'br', 'han', 'gaiji', 'Link',
                         'chr', 'bold', 'italic', 'under', 'sup', 'sub',
                         'chem', 'div', 'nom', 'den', );
        }
        my @sgm_blk;  { # 入力sgmlを 主要なタグで分割する。
            # 入力sgmlを 主要なタグで分割する。
                sepTG(  \@sgm,  \@sgm_blk  );
        }
        my @old_blk;  { # 比較sgmlを 主要なタグで分割する。
            # 比較sgmlを 主要なタグで分割する。
                sepTG(  \@old,  \@old_blk  );
        }
        # 比較ブロックを作る。
            @cmp = ();
            my $n = 0; my %t = map do { $_ => ++$n }, @tags;
            my @s = @sgm_blk; my @o = @old_blk; my $s = 0; my $o = 0;
            while( @s || @o ) {
                my ( $sf, $of ) = ( $s <= $o, $o <= $s );
                push @cmp, [ 'cmp', $sf ? shift @s : [] , $of ? shift @o : [] ];
                $sf && (
                    $s = @s && @{$s[0][0]}[0] =~ /^<(\S+?)[\s>]/ && defined( $t{ $1 } ) ?
                             $t{ $1 } : ( @s ? $s : $n ), # msg( "s : $s $1" )
                );
                $of && (
                    $o = @o && @{$o[0][0]}[0] =~ /^<(\S+?)[\s>]/ && defined( $t{ $1 } ) ?
                             $t{ $1 } : ( @o ? $o : $n ), # msg( "o : $o $1", '' )
                );
            }
        # 属性タグを 前の行に連結する。
            my $t = '('.( join '|', @atr ).')';
            for( @cmp ) {
                my ( undef, $s, $o, ) = @$_; my $p = undef;
                for( @$s, undef, @$o ) {
                    defined( $_ ) && ( join '', @$_ ) =~ /^<\/?$t[\s>]/ && defined( $p ) ||
                        ( $p = $_, next );
                    push @$p, @$_; $_ = [];
                }
                @$s = map do { @$_ ? $_ : () }, @$s;
                @$o = map do { @$_ ? $_ : () }, @$o;
            }
        #  デバグ用出力あり ならば 'chk_cmp.txt' に比較結果を出力する。
        # 比較ブロックに 'cmp' があれば 類似度の高いペアにより分離する。 を行う。
            msg( '  comparing ...' );
            my $n = 0;
            while( $n < @cmp ) {
                $n = 0; for( @cmp ) { $$_[0] eq 'cmp' && last; $n++; }
                sep_pare( $n );
            }
        # デバグ用出力あり ならば 'chk_cmp.txt' に比較結果を出力する。
            if( $opt =~ /d/i ) { putF_cmp(  'chk_cmp.txt' ) }
    }

    sub sep_pare { # 類似度の高いペアにより分離する。 
        my $n = $_[0]; # 比較ブロックの番号 
        my $cb = $cmp[ $n ]; # 対象とする比較ブロック 
        my @pare; # 類似度の高いペアの番号 
        my $d_msg = ''; # '', 'A', 'B' or 'AB'; # 途中経過の確認メッセージの表示 
        my $d_sep = 0; # 0 or 1; # 文字への分解を残す 
        # １文字ずつに分けて 連続する２文字のリストを作り ソートする。
            my $s = sep_chr( $$cb[1] ); get_moji2( $s ); sort_moji2( $s );
            my $o = sep_chr( $$cb[2] ); get_moji2( $o ); sort_moji2( $o );
            push @{$cb}, $s, $o;
        # 類似度の高い文字列ブロックのペアを探す。
            @pare = ();
            my @s = @{$$cb[3]}; my @o = @{$$cb[4]};
            @pare || ( $dmax = 12, $dsame =  6, $dlen = 16, get_pare( \@pare, \@s, \@o ) );
            @pare || ( $dmax = 24, $dsame =  9, $dlen = 36, get_pare( \@pare, \@s, \@o ) );
            @pare || ( $dmax = 40, $dsame = 12, $dlen = 70, get_pare( \@pare, \@s, \@o ) );
            if( $d_msg =~ /A/ && $dsame == 3 || $d_msg =~ /B/ && $dsame != 3 ) {
                my @p = @pare; my $k = $dsame == 3 ? 'A' : 'B' ;
                while( @p ) {
                    my ( $i, $j ) = splice( @p, 0, 2 );
                    msg( '', "=== b:$n  s:$i o:$j $k", ( join '', @{@{$$cb[1]}[$i]} ),
                         "---", ( join '', @{@{$$cb[2]}[$j]} ) );
                }
                @pare && `pause`;
            }
        # 類似度の高いペアがあれば そのペアで分離する。
            if( @pare ) {
                my @sp = ();
                my @s = @{$$cb[1]}; my @o = @{$$cb[2]};
                while( @pare ) {
                    my ( $i, $j, ) = splice( @pare, -2, 2 );
                    my @s_r = splice( @s, $i + 1 ); my @o_r = splice( @o, $j + 1 );
                    my $st = ! @s_r ? 'del' : ! @o_r ? 'ins' : 'cmp' ;
                    ( @s_r || @o_r ) && unshift @sp, [ $st, [ @s_r ], [ @o_r ] ];
                    @s && @o && unshift @sp, [ 'near', [ pop @s ], [ pop @o ] ];
                }
                ( @s || @o ) &&
                    unshift @sp, [ ! @s ? 'del' : ! @o ? 'ins' : 'cmp' , [ @s ], [ @o ] ];
                splice( @cmp, $n, 1, @sp );
            }
            else {
                $$cb[0] = ! @{$$cb[1]} ? 'del' : ! @{$$cb[2]} ? 'ins' : 'pass' ;
                $d_sep || splice( @{$cb}, -2 );
            }
    }

# - 照合

    %v_mark;  { # 挿入するマーク
        # 挿入するマーク
            %v_mark = (
                'del'  => '<my:del>',  '/del'  => '</my:del>',
                'ins'  => '<my:ins>',  '/ins'  => '</my:ins>',
                'same' => '<my:same>', '/same' => '</my:same>',
            );
    }
    { #+ 比較ブロック内で 精密な照合を行う。
        # 比較ブロックが 'near' のとき 一致箇所にマークを挿入する。 を行う。
            msg( '  verifying ...' );
            my $n = 0;
            while( $n < @cmp ) {
                $n = 0; for( @cmp ) { $$_[0] =~ /^near$/ && last; $n++; }
                vrf_same( $n );
            }
        # 比較ブロックが 'pass' のとき 一致箇所にマークを挿入する。 を行う。
            my $n = 0;
            while( $n < @cmp ) {
                $n = 0; for( @cmp ) { $$_[0] =~ /^pass$/ && last; $n++; }
                vrf_same( $n );
            }
        # 比較ブロックの 'ins' 'del' にも 一致箇所にマークを挿入する。 を行う。
            for( my $n = 0; $n < @cmp; $n++ ) {
                ${$cmp[$n]}[0] =~ /^(ins|del)$/ || next; vrf_same( $n );
            }
        # デバグ用出力あり ならば 'chk_vrf.txt' に比較結果を出力する。
            if( $opt =~ /d/i ) { putF_cmp(  'chk_vrf.txt' ) }
    }

    sub vrf_same { # 一致箇所にマークを挿入する。 
        my $n = $_[0]; # 比較ブロックの番号 
        my $cb = $cmp[ $n ]; # 対象とする比較ブロック 
        my $d_vmsg = 0; # 0 or 1; # 途中経過の確認メッセージの表示 
        my $d_vrf = 1; # 0 or 1; # 文字への分解を残す 
        # 文字列ブロックを１つにまとめ さらに１文字ずつに分ける。
            my $s = [ map do { "\x0a", @$_ }, @{ sep_chr( $$cb[1] ) } ];
            my $o = [ map do { "\x0a", @$_ }, @{ sep_chr( $$cb[2] ) } ];
            shift @$s; shift @$o;
            push @{$cb}, [ $s ], [ $o ];
        # 一致箇所を探し マークを挿入する。
            my @s = @{@{$$cb[3]}[0]}; my @o = @{@{$$cb[4]}[0]};
            my @mark = (); my @mark2 = ();
            my @check = ( [ 0, scalar @s - 1, 0, scalar @o - 1 ] );
            while( @check ) {
                my $c = shift @check; my ( $ss, $se, $os, $oe, ) = @$c;
                $ss > $se && $os <= $oe &&
                    push @mark, [ $ss, 'del'], [ $ss, "o:$os-$oe"], [ $ss, '/del'];
                $ss <= $se && $os > $oe &&
                    push @mark, [ $ss, 'ins' ], [ $se + 1, '/ins' ];
                $ss <= $se && $os <= $oe || next;
                my @f = find_same( \@s, \@o, @$c, $d_vmsg );
                $f[0] <= $f[1] || do {
                    push @mark, [ $ss, 'del'], [ $ss, "o:$os-$oe"], [ $ss, '/del'],
                                [ $ss, 'ins' ], [ $se + 1, '/ins' ];
                    next;
                };
                push @mark2, [ $f[0], 'same' ]; push @mark, [ $f[1] + 1, '/same' ];
                ( $ss < $f[0] || $os < $f[2] ) &&
                    push @check, [ $ss, $f[0] - 1, $os, $f[2] - 1 ];
                ( $f[1] < $se || $f[3] < $oe ) &&
                    push @check, [ $f[1] + 1, $se, $f[3] + 1, $oe ];
                @check = sort { $$a[0] <=> $$b[0] } @check;
            }
            # @mark を @sに反映させる。
                my @m = sort { $$a[0] <=> $$b[0] } @mark, @mark2;
                while( @m ) {
                    my ( $p, $m ) = @{ pop @m };
                    $m =~ /^o:(\d+)-(\d+)$/ || ( splice( @s, $p, 0, $v_mark{ $m } ), next );
                    my $os = $1; my $oe = $2;
                    my @ox = splice( @o, $os, $oe - $os + 1 ); splice( @o, $os, 0, @ox );
                    splice( @s, $p, 0, @ox );
                }
            push @{$cb}, [ [ @s ] ];
        # 'near' のとき 先頭の相違を １つ前の比較ブロックに移す。
            my $pb = ( 0 < $n ) ? $cmp[ $n - 1 ] : undef ;
            my $v = ( $$cb[0] eq 'near' ) ? @{$$cb[ @$cb - 1 ]}[0] : undef ;
            defined( $pb ) && $$pb[0] eq 'pass' && defined( $v ) &&
                ( $$v[0] =~ /^<my:(ins|del)>$/ ||
                  $$v[0] eq '<my:same>'  && $$v[1] =~ /^<\/\S+>$/ &&
                  $$v[2] eq '</my:same>' && $$v[3] =~ /^<my:(ins|del)>$/ ) && do {
                my $si = ''; my $sd = '';
                $$v[0] eq '<my:same>' &&
                    ( $si .= $$v[1], $sd .= $$v[1], splice( @$v, 0, 3 ) );
                while( $$v[0] =~ /^<my:(ins|del)>$/ ) {
                    my $k = $1; shift @$v; my $x = ( $k eq 'ins' ) ? \$si : \$sd ;
                    my $u; while( ( $u = shift @$v ) ne "</my:$k>" ) { $$x .= $u; }
                }
                push @{$$pb[1]}, map do { [ $_ ] }, split "\x0a", $si;
                push @{$$pb[2]}, map do { [ $_ ] }, split "\x0a", $sd;
            };
        # 文字列ブロックに戻す。
            my $s = join '', map do { join '', @$_ }, @{$$cb[3]};
            my $o = join '', map do { join '', @$_ }, @{$$cb[4]};
            @{$$cb[1]} = map do { [ $_ ] }, split "\x0a", $s;
            @{$$cb[2]} = map do { [ $_ ] }, split "\x0a", $o;
            $$cb[0] = 'verified';
            $d_vrf || splice( @{$cb}, -2 );
    }

# - 補正

    @adj;  # 補正結果 
    { #+ 比較結果を見やすく補正する。
        # 比較ブロックから文字列を取り出す。
            @adj = map do { @{ @{$$_[ @$_ - 1 ]}[0] } }, @cmp;
        # カナの相違を見やすくする。
            msg( '  adjusting ...' );
            my $v = \@adj; my @p; my $ns = 0;
            while( @p = find_K( $v, $ns ) ) {
                my ( $n, $m, $l ) = @p; my @v; $ns = $n;
                # sameの先頭のカナを delとinsの末尾に移動する。
                    @v = splice( @$v, $m + 2, $l );
                    splice( @$v, $n, 0, @v ); $n += $l; $m += $l;
                    splice( @$v, $m, 0, @v ); $m += $l;
                    # </del><ins>・・・</ins><same>カナ
                    #                ↓
                    # カナ</del><ins>・・・カナ</ins><same>;
                # sameが空になる || next;
                    $$v[ $m + 1 ] eq '<my:same>' && $$v[ $m + 2 ] eq '</my:same>' || next;
                # 空のsameを削除する。
                    splice( @$v, $m + 1, 2 );
                 # del ins del となる || next
                     $$v[ $m ] eq '</my:ins>' && $$v[ $m + 1 ] eq '<my:del>' || next;
                # del を合体する。
                    for( $l = $m + 2; $l < @$v && $$v[ $l ] ne '</my:del>'; $l++ ) { ; }
                    $l -= $m + 2;
                    @v = splice( @$v, $m + 2, $l );
                    splice( @$v, $n, 0, @v ); $n += $l; $m += $l;
                    splice( @$v, $m + 1, 2 );
                    # </del><ins>・・・</ins><del>文字列
                    #                ↓
                    # 文字列</del><ins>・・・</ins>;
                # ins ins となる || next
                    $$v[ $m ] eq '</my:ins>' && $$v[ $m + 1 ] eq '<my:ins>' || next;
                # ins を合体する。
                    splice( @$v, $m, 2 );
                    # </del><ins>・・・</ins><ins>文字列
                    #               ↓
                    # </del><ins>・・・文字列;
            }
        # １文字のかなの相違を見やすくする。
            my $v = \@adj; my @p; my $ns = 0;
            while( @p = find_H( $v, $ns ) ) {
                my ( $n, $m, $l ) = @p; my @v; $ns = $n;
                # sameのかな１文字を delとinsの末尾に移動する。
                    @v = splice( @$v, $m + 2, $l );
                    splice( @$v, $n, 0, @v ); $n += $l; $m += $l;
                    splice( @$v, $m, 0, @v ); $m += $l;
                    # </del><ins>・・・</ins><same>かな
                    #                ↓
                    # かな</del><ins>・・・かな</ins><same>;
                # sameが空になる || next;
                    $$v[ $m + 1 ] eq '<my:same>' && $$v[ $m + 2 ] eq '</my:same>' || next;
                # 空のsameを削除する。
                    splice( @$v, $m + 1, 2 );
                 # del ins del となる || next
                     $$v[ $m ] eq '</my:ins>' && $$v[ $m + 1 ] eq '<my:del>' || next;
                # del を合体する。
                    for( $l = $m + 2; $l < @$v && $$v[ $l ] ne '</my:del>'; $l++ ) { ; }
                    $l -= $m + 2;
                    @v = splice( @$v, $m + 2, $l );
                    splice( @$v, $n, 0, @v ); $n += $l; $m += $l;
                    splice( @$v, $m + 1, 2 );
                    # </del><ins>・・・</ins><del>文字列
                    #                ↓
                    # 文字列</del><ins>・・・</ins>;
                # ins ins となる || next
                    $$v[ $m ] eq '</my:ins>' && $$v[ $m + 1 ] eq '<my:ins>' || next;
                # ins を合体する。
                    splice( @$v, $m, 2 );
                    # </del><ins>・・・</ins><ins>文字列
                    #               ↓
                    # </del><ins>・・・文字列;
            }
        # 先頭の終了タグを見やすくする。
            my $v = \@adj; my @p; my $ns = 0;
            while( @p = find_E( $v, $ns ) ) {
                my ( $n, $nl, $m, $ml ) = @p; my @v; $ns = $n;
                # sameの区切りを移動する。
                    @v = splice( @$v, $m, 2 ); splice( @$v, $m + $ml, 0, @v ); $m += $ml;
                    $n || ( splice( @$v, 0, 0, '<my:same>', '</my:same>' ), $n = 2 );
                    @v = splice( @$v, --$n, 2 ); splice( @$v, $n + $nl, 0, @v ); $n += $nl;
                    # </same><del or ins>タグ・・・</del or ins><same>タグ
                    #                          ↓
                    # タグ</same><del or ins>・・・タグ</del or ins><same>;
                # sameが空になる || next;
                    $$v[ $m + 1 ] eq '<my:same>' && $$v[ $m + 2 ] eq '</my:same>' || next;
                # 空のsameを削除する。
                    splice( @$v, $m + 1, 2 );
                # del ins del となる || next
                    $$v[ $m ] eq '</my:ins>' && $$v[ $m + 1 ] eq '<my:del>' || next;
                # del を合体する。
                    for( $l = $m + 2; $l < @$v && $$v[ $l ] ne '</my:del>'; $l++ ) { ; }
                    $l -= $m + 2;
                    @v = splice( @$v, $m + 2, $l );
                    splice( @$v, $n, 0, @v ); $n += $l; $m += $l;
                    splice( @$v, $m + 1, 2 );
                    # </del><ins>・・・</ins><del>文字列
                    #                ↓
                    # 文字列</del><ins>・・・</ins>;
                # ins ins となる || next
                    $$v[ $m ] eq '</my:ins>' && $$v[ $m + 1 ] eq '<my:ins>' || next;
                # ins を合体する。
                    splice( @$v, $m, 2 );
                    # </del><ins>・・・</ins><ins>文字列
                    #               ↓
                    # </del><ins>・・・文字列;
            }
        # 比較結果を確認する。
            my $d = join '', map do {
                my $v = @$_[ scalar @$_ - 1 ]; map do { join '', @$_ }, @$v;
            }, @cmp;
            $d =~ s/<\/?my:same>//g;
            my $n = ''; my $o = '';
            while( $d =~ /<my:(ins|del)>/ ) {
                $n .= $`; $o .= $`; $d = $'; my $k = $1; $d =~ /<\/my:$k>/ || last;
                $d = $'; if( $k eq 'ins' ) { $n .= $`; } else { $o .= $` }
            }
            $n .= $d; $o .= $d;
            $n =~ s/&amp;(enter;)/&$1/g; $n =~ s/\x0a//g; $n =~ s/\\t/\t/g;
            $n =~ s/\\n/\x0a/g; $n =~ s/\\((\\)+[tn])/$1/g; $n =~ s/\x0a+/\x0a/g;
            $o =~ s/&amp;(enter;)/&$1/g; $o =~ s/\x0a//g; $o =~ s/\\t/\t/g;
            $o =~ s/\\n/\x0a/g; $o =~ s/\\((\\)+[tn])/$1/g; $o =~ s/\x0a+/\x0a/g;
            my $ss = join '', getF( $fol.$fn );  $ss =~ s/\x0a+/\x0a/g;
            my $so = join '', getF( $fol.$ofn ); $so =~ s/\x0a+/\x0a/g;
            $n eq $ss && $o eq $so || msg( '  比較結果を正しく作成できませんでした。' );
            # デバグ用出力あり ならば unlink( 'chk_no.txt', 'chk_ni.txt', 'chk_oo.txt', 'chk_oi.txt' );
                if( $opt =~ /d/i ) {  unlink( 'chk_no.txt', 'chk_ni.txt', 'chk_oo.txt', 'chk_oi.txt' ); }
            # デバグ用出力あり && $n ne $ss ならば msg( '  output: chk_no.txt, chk_ni.txt' ); putF( 'chk_no.txt', $n ); putF( 'chk_ni.txt', $ss );
                if( $opt =~ /d/i && $n ne $ss  ) {  msg( '  output: chk_no.txt, chk_ni.txt' ); putF( 'chk_no.txt', $n ); putF( 'chk_ni.txt', $ss ); }
            # デバグ用出力あり && $o ne $so ならば msg( '  output: chk_oo.txt, chk_oi.txt' ); putF( 'chk_oo.txt', $o ); putF( 'chk_oi.txt', $so );
                if( $opt =~ /d/i && $o ne $so  ) {  msg( '  output: chk_oo.txt, chk_oi.txt' ); putF( 'chk_oo.txt', $o ); putF( 'chk_oi.txt', $so ); }
        # 差分情報を含むsgmlを作成 ならば 比較結果をSGML形式で出力する。
            if( $opt =~ /f/i ) { 
                my @o = map do {
                    my $v = @$_[ scalar @$_ - 1 ]; map do { join '', @$_ }, @$v;
                }, @cmp;
                for( @o ) {
                    s/<\/?my:same>//g;
            #            s/<\/?my:ins>//g; s/<my:del>(.|\s)*?<\/my:del>//g;
            #            s/<my:ins>(.|\s)*?<\/my:ins>//g; s/<\/?my:del>//g;
                    s/&amp;(enter;)/&$1/g;
                    s/\x0a//g; s/\\t/\t/g; s/\\n/\x0a/g; s/\\((\\)+[tn])/$1/g;
                }
                my $f = $fn; $f =~ s/\.sgm$/_diff.sgm/i;
                msg( '  output: '.$f );
                putF( $fol.$f, join '', @o );
            }
    }

# - 出力

    @out;  { # 出力html
        # 出力html
            @out = ();
        my %h_mark;  { # マークに対応するhtml
            # マークに対応するhtml
                my @c = ( '#6666ee', '#ee5566' );
                # 赤・青反転 ならば @c = reverse @c
                    if( $opt =~ /c/i ) {  @c = reverse @c }
                %h_mark = (
                    '<my:del>'  => '<font color=white style="background-color:'.$c[0].'">',
                    '</my:del>'  => '</font>',
                    '<my:ins>'  => '<font color=white style="background-color:'.$c[1].'">',
                    '</my:ins>'  => '</font>',
                    '<my:same>' => '', '</my:same>' => '',
                );
        }
        my $h_head;  { # ヘッダ
            # ヘッダ
                @h_head = (
                    '<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">',
                    '<HTML>',
                    '<META http-equiv=Content-Type content="text/html; charset=shift_jis">',
                    '<HEAD><TITLE>', 'mdevSGML_sc：'.$fn, '</TITLE>',
                    '</HEAD><BODY bgColor=white>',
                );
        }
        my $h_exp;  { # 冒頭の説明
            # 冒頭の説明
                $h_exp = join "\x0a", (
                    '<table><tr><td colspan=2>SGMLファイルの比較 （ 色の意味：　'.
                    '<my:del>削除文字列</my:del>　<my:ins>挿入文字列</my:ins> ）',
                    '<tr><td>　　新しいSGML　　'.$fn .'<td><small>　'.get_mt( $fol.$fn  ),
                    '<tr><td>　　元のSGML　　　'.$ofn.'<td><small>　'.get_mt( $fol.$ofn ),
                    '</table>',
                );
                $h_exp .= '<hr>';
                $h_exp =~ s/<\/?my:.*?>/$h_mark{ $& }/g;
        }
        my @h_foot;  { # フッタ
            # フッタ
                @h_foot = (
                    '<br></BODY></HTML>',
                );
        }
        # 一致箇所のマークを htmlタグに変える。
            msg( '  converting ...' );
            for( @adj ) {
                /<\/?my:.*?>/ && ( s/<\/?my:.*?>/$h_mark{ $& }/g, next );
                s/</&lt;/g, s/>/&gt;/g;
            }
            @out = split "\x0a", join '', @adj;
        # 相違箇所の前後のみ表示 ならば 相違箇所の前後のみを抽出する。
            if( $opt =~ /s/i ) { 
                my @f = map do { $h_mark{ $_ } }, ( '<my:ins>', '<my:del>' ); uniqueA( \@f );
                my $font = '('.( join '|', @f ).')'; my $font_e = '</font>';
                my @m = (); my $f = 0; my $n = -1; my $d = 3;
                for( @out ) {
                    ++$n; $f || /$font/ || /$font_e/ || next;
                    push @m, $n; /^(?:.|\s)*($font|$font_e)/ && ( $f = $1 ne $font_e );
                }
                my $br = "<br>\n";
                my @o = @out; @out = ( $br.$br.'相違箇所の前後のみを表示'.$br ); my $an = 1;
                for( $n = 0; $n < @m; $n++ ) {
                    my $s = ( $m[ $n ] < $d ) ? 0 : $m[ $n ] - $d ;
                    while( $n + 1 < @m && $m[ $n + 1 ] <= $m[ $n ] + $d ) { $n++; }
                    my $e = ( $m[ $n ] + $d < @o ) ? $m[ $n ] + $d : @o ;
                    push @out, "$br******<a name=$an></a>$br"; $an++;
                    for( my $i = $s; $i < $e + 1; $i++ ) { push @out, $o[ $i ]; }
                    push @out, $br;
                }
            }
        # タブと改行をアンエスケープする。
            my $atr   = '('.( join '|', 'variablelabel', @atr ).')(&gt;|\s)';
            my $atr_e = '('.( join '|', @pass, @atr ).')(&gt;|\s)';
            my @f = map do { $_ eq '' ? () : $_ }, values %h_mark; uniqueA( \@f );
            my $font = '(\s|'.( join '|', @f ).')';
            my $out = join "\x0a", @out;
            $out =~ s/&amp;enter;(\\n)?/$&<br>/g;
            $out =~ s/&lt;(?!\/)(?!$atr)\S+(&gt;|\s)/<br>$&/g;
            $out =~ s/&lt;\/(?!$atr)(.|\s)*?&gt;(\\n)?$font*(?=&lt;\/(?!$atr_e))/$&<br>/g;
        #        $out =~ s/\\t/\t/g; $out =~ s/\\n/<br>/g; $out =~ s/\\((\\)+[tn])/$1/g;
            $out =~ s/\\t/\t/g; $out =~ s/\\n//g; $out =~ s/\\((\\)+[tn])/$1/g;
            $out =~ s/^<br>//;
            @out = split "\x0a", $out;
        # htmlの体裁を整える。
            unshift @out, @h_head, $h_exp; push @out, @h_foot;
        # 結果を出力する。
            msg( '  output: '.$hfn );
            putF( $fol.$hfn, join "\x0a", @out );
        # デバグ用出力あり ならば 'chk_out.htm' に結果を出力する。
            if( $opt =~ /d/i ) { putF(  'chk_out.htm',  join "\x0a",  @out  ); }
    }

#  処理の詳細 ‥

# - 開始

# - 入力ファイル・比較ファイル

# - エスケープ

# - 比較

    sub getF_tags { # 主要なタグを( fn )から読む。 
        -f $_[0] || err( '  タグリストがありません。' );
        @tags = getF( $_[0] );
        for( @tags ) { s/\s*$//; }
    }

    sub sepTG { # ( sgml )を 主要なタグ で分割し( block )に格納する。 
        my ( $sgml, $block, ) = @_;
        my @b = ();
        my @t = map do { /^\// ? () : $_ }, @tags;
        my $p = '('.( join '|', @pass ).')';
        my $r = 0;
        for( @{$sgml} ) {
            my $m = @$_[0];
            $m =~ /^<\/?$p[\s>]/ && ( ( push @b, $_ ), next );
            my $n = 0;
            for( ; $n < @t; $n++ ) { my $t = $t[ $n ]; $m =~ /^<\/?$t[\s>]/ && last; }
            $n < @t && ( $r = $n, @b && ( push @{$block}, [ @b ] ), @b = () );
            push @b, $_;
        }
        @b && push @{$block}, [ @b ];
    }

    sub sep_chr { # ( array )を１文字ずつに分ける。 
        my @m = map do { join '', @$_ }, @{$_[0]};
        my @fmt = (
            '<[!/]?[.0-9a-zA-Z\s="_-]+>?', '\&amp;enter;', '\&amp;',
            '(?:\\\\)+[tn]', '\*+', '\d+', '[\x00-\x7f\xa0-\xdf]',
            '順序番号', '項目名', '内容', '..',
        );
        my @fmt_t = ( '<\S+', '[^="_\.\d\s]+', '\d+', '\s+', '.' ); # '"[^"]*"',
        my $fmt   = '('.( join '|', @fmt ).')';
        my $fmt_t = '('.( join '|', @fmt_t ).')';
        @m = map do { [ /$fmt/g ] }, @m;
        @m = map do { [ map do { /^</ ? /$fmt_t/g : $_ }, @$_ ] }, @m;
        [ @m ];
    }

    sub get_moji2 { # ( array )を連続する２文字のリストにする。 
        for( @{$_[0]} ) {
            my $n = @{$_}; # 要素数
            my @l = ();
            push @l, "\x0a\t".$$_[0];
            for( my $i = 0; $i < $n - 1; $i++ ) {
                push @l, $$_[ $i ]."\t".$$_[ $i + 1 ];
            }
            push @l, $$_[ $n - 1 ]."\t\x0a";
            @{$_} = @l;
        }
    }

    sub sort_moji2 { # ( array )の連続する２文字のリストをソートする。 
        for( @{$_[0]} ) {
            @$_ = sort { $a cmp $b } @$_; # uniqueA( $_ );
        }
    }

    sub get_pare { # 類似度の高いペアを探す。 
        my ( $pare, $s, $o, ) = @_;
        my $i = 0; $j = 0;
        while( 1 ) {
            my @p = ();
            for( my $p = $i; $p < @$s; $p++ ) {
                @{$$s[$p]} < $dlen && next;
                my $m = $dmax; my @q = ();
                for( my $q = $j; $q < @$o; $q++ ) {
                    @{$$o[$q]} < $dlen && next;
                    my $d = get_diff2( $$s[$p], $$o[$q] ); $d < $dmax || next;
                    $d == $m && push @q, [ $p, $q, $m ];
                    $d < $m && ( $m = $d, @q = ( [ $p, $q, $p < $q ? $q : $p, $m ] ) );
                }
                @q && $m < $dsame || next;
                @q = sort { $$a[0] cmp $$b[0] } @q;
                push @p, [ @{$q[0]}, scalar @q ];
            }
            @p || last;
            @p =  sort { $$a[3] <=> $$b[3] } sort { $$a[4] <=> $$b[4] }
                  sort { $$a[2] <=> $$b[2] } reverse @p;
            ( $i, $j, ) = @{$p[0]};
            push @$pare, ( $i, $j ); $i++; $j++;
        }
    }

    sub get_diff2 { # ２行の類似度を調べる。 
        my ( $a, $b, ) = @_;
        my $ai = 0; my $an = @{$a}; my $ad = 0;
        my $bi = 0; my $bn = @{$b}; my $bd = 0;
        while( $bi < $bn ) {
            $ad < $dmax && $bd < $dmax || last;
            my $x = $ai < $an ? $$a[$ai] cmp $$b[$bi] : 1 ;
            $x == 0 && ( $ai++, $bi++, next );
            $x < 0  && ( $ad++, $ai++, next );
            $x > 0  && ( $bd++, $bi++, next );
        }
        $ai < $an && ( $ad += $an - $ai, $bd += $an - $ai );
        my $r = ( $an < $dlen || $an - $ad < $dlen ) ? $dmax :
                $ad < $bd ? $ad : $bd ;
        $r;
    }

    sub putF_cmp { # ( fn )に比較結果を出力する。 
        @cmp_out = map do {
            my ( $st, $s, $o, $s2, $o2, $v2, ) = @$_;
            (
                '', '========== '.$st, ( map do { join '', @$_ }, @$s ),
                '----------', ( map do { join '', @$_ }, @$o ),
                ( ! @$s2 && ! @$o2 ? () :
                    ( '‥‥‥‥‥', ( map do { '--- '.@$_, @$_, }, @$s2 ),
                      '----------', ( map do { '--- '.@$_, @$_, }, @$o2 ) )
                ),
                ( ! defined( $v2 ) || ! @$v2 ? () : ( '‥‥‥‥‥', @{@$v2[0]} ) ),
            );
        }, @cmp;
        push @cmp_out, '';
        putF( $_[0], join "\x0a", @cmp_out );
    }

# - 照合

    sub find_same { # 一致箇所を探す。 
        my ( $s, $o, $ss, $se, $os, $oe, $d_msg, ) = @_;
        $d_msg && msg_pare( $s, $o, $ss, $se, $os, $oe, "====== $ss $se   $os $oe" );
        my $fmt  = '(?:[\x80-\x9f\xe0-\xef].)$';
        my $fmt2 = '(?:\x83[\x40-\x7e\x80-\x96]|\x81\x5b)';
        my $fmt3 = '(?:</?(?!serialno|item|detail|variablelabel)\S+)';
        my $fmt4 = '(?:onswitch|onoff| |=|"|off)';
        my $l_max = 0; my @l = ( [ $ss, $ss - 1, $os, $os - 1 ] );
        for( my $pss = $ss; $pss < $se + 1; $pss++ ) {
            for( my $pos = $os; $pos < $oe + 1; $pos++ ) {
                my $pse = $pss; my $poe = $pos; my $l = 0;
                while( $pse < $se + 1 && $poe < $oe + 1 ) {
                    $$s[ $pse ] eq "\x0a" && ( $pse++, next );
                    $$o[ $poe ] eq "\x0a" && ( $poe++, next );
                    $$s[ $pse ] eq $$o[ $poe ] || last;
                    $$s[ $pse ] =~ /^$fmt/  && ( $l += 2 );
                    $$s[ $pse ] =~ /^$fmt2/ && ( $l += 2 );
                    $$s[ $pse ] =~ /^$fmt3/ && ( $l += 1 );
                    $$s[ $pse ] =~ /^$fmt4/ && ( $l -= 1 );
                    $pse++, $poe++, $l++;
                }
                $pse--, $poe--;
                $l_max == $l && push @l, [ $pss, $pse, $pos, $poe ];
                $l_max < $l && ( $l_max = $l, @l = ( [ $pss, $pse, $pos, $poe ] ) );
            }
        }
        my @f = @{ shift @l };
        $d_msg && $l_max && msg_pare( $s, $o, @f, "--- $f[0] $f[1]   $f[2] $f[3]" );
        $d_msg && ! $l_max && msg( '--- none', '' );
        @f;
    }

    sub msg_pare { # 文字列ペア( as )( ao )( ss )( se )( os )( oe )( m )を表示する。 
        my $ms = ''; for( my $i = $_[2]; $i < $_[3] + 1; $i++ ) { $ms .= @{$_[0]}[$i] }
        my $mo = ''; for( my $i = $_[4]; $i < $_[5] + 1; $i++ ) { $mo .= @{$_[1]}[$i] }
        msg( $_[6], $ms, '---', $mo, '' ); `pause`;
    }

# - 補正

    sub find_K { # delの最後がカナで insをはさんで sameの先頭がカナのところ を探す。 
        my $v = $_[0]; my $ns = $_[1];
        my $kana = '(?:\x83[\x40-\x7e\x80-\x96]|\x81\x5b)';
        my $n, $m, $l;
        for( $n = $ns; $n < @$v; $n++ ) {
            $$v[ $n ] eq '</my:del>' && 0 < $n && $$v[ $n -  1 ] =~ /^$kana$/ &&
                $n < @$v - 1 && $$v[ $n + 1 ] eq '<my:ins>' || next;
            for( $m = $n + 2; $m < @$v && $$v[ $m ] ne '</my:ins>'; $m++ ) { ; }
            $m + 2 < @$v &&
                $$v[ $m + 1 ] eq '<my:same>' && $$v[ $m + 2 ] =~ /^$kana$/ || next;
            for( $l = $m + 3; $l < @$v && $$v[ $l ] =~ /^$kana$/; $l++ ) { ; }
            last;
        }
        $n < @$v ? ( $n, $m, $l - $m - 2 ) : () ;
    }

    sub find_H { # delとinsの後のsameが かな１文字のところ を探す。 
        my $v = $_[0]; my $ns = $_[1];
        my $hira = '(?:\x82[\x9f-\xf1]|\x81\x5b)';
        my $n, $m, $l;
        for( $n = $ns; $n < @$v; $n++ ) {
            $$v[ $n ] eq '</my:del>' &&
                $n < @$v - 1 && $$v[ $n + 1 ] eq '<my:ins>' || next;
            for( $m = $n + 2; $m < @$v && $$v[ $m ] ne '</my:ins>'; $m++ ) { ; }
            $m + 4 < @$v &&
                $$v[ $m + 1 ] eq '<my:same>' && $$v[ $m + 2 ] =~ /^$hira$/ &&
                $$v[ $m + 3 ] eq '</my:same>' &&
                $$v[ $m + 4 ] =~ /^<my:(ins|del)>$/ || next;
            last;
        }
        $n < @$v ? ( $n, $m, 1 ) : () ;
    }

    sub find_E { # del・ins の頭が終了タグで 直後の same の頭が同じタグのところ を探す。 
        my $v = $_[0]; my $ns = $_[1];
        my $etag = '(?:</\S+>)';
        my $n, $nl = 1, $m, $ml = 1;
        for( $n = $ns; $n < @$v; $n++ ) {
            $$v[ $n ] =~ /^<my:(ins|del)>$/ &&
                ! ( 0 < $n && $$v[ $n - 1 ] ne '</my:same>' ) || next;
            my $e = "</my:$1>"; my $p = '';
            for( $m = $n + 1; $m < @$v && $$v[ $m ] ne $e; $m++ ) { $p .= $$v[ $m ]; }
            $p =~ /^\x0a?($etag)/ || next; my $t = $1;
            $m + 1 < @$v && $$v[ $m + 1 ] eq '<my:same>' || next;
            $e = "</my:same>"; my $l; my $q = '';
            for( $l = $m + 2; $l < @$v && $$v[ $l ] ne $e; $l++ ) { $q .= $$v[ $l ]; }
            $q =~ /^\x0a?$t/ || next;
            $nl = ( $p =~ /^\x0a/ ) ? 2 : 1 ;
            $ml = ( $q =~ /^\x0a/ ) ? 2 : 1 ;
            last;
        }
        $n < @$v ? ( $n, $nl, $m, $ml ) : () ;
    }

# - 出力

    sub uniqueA { # ( array )の重複を除去する 
        my $n = '';
        @{$_[0]} = map do { my $p = $n; $n = $_; $p eq $n ? () : $n; }, @{$_[0]};
    }

    sub get_mt { # ( fn )のタイムスタンプ 
        my $fn = $_[0];
        my ( $s, $m, $h, $d, $n, $y, ) = localtime( @{[ lstat( $fn ) ]}[9] );
        $y += 1900; $n++;
        sprintf "%04d/%02d/%02d %02d:%02d:%02d", $y, $n, $d, $h, $m, $s;
    }

# - 補助の定型ルーチン

    sub quotemeta_ja { # 日本語文字列( str )のquotemeta 
        join '', map do{ s/(.)([\x40\x5b-\x60\x7b-\x7f])/$1\\$2/; $_ ; },
            ( $_[0] =~ /([\x00-\x7f\xa0-\xdf]|..)/g );
    }

    sub getF { # ファイル( name )を読む。 
        open( IN, '<'.$_[0] ) || err( 'オープンエラー：'.$_[0] );
        my @buf = <IN>; close( IN );
        @buf;
    }

    sub putF { # ファイル( name )に( string )を出力する。 
        if( open( OUT, '>'.$_[0] ) ) { print OUT $_[1]; close( OUT ); }
        else { err( 'オープンエラー：'.$_[0] ); }
    }

    sub err { # メッセージ( array )を表示して エラー終了する。 
        msg( @_ ); exit( 1 );
    }

    sub msg { # メッセージ( array )を表示する。 
        print map do { $_."\x0a" }, @_;
    }

# - 構文

# - ライセンス
# ~   スクリプトの冒頭に記述。