# mdevSGML_s2w ( ver 0.1 ) :
# This program converts Medical Device SGML to it's Word data form.
#   Written by prepress-tips 2009.1.27
#   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.

    use Encode qw/encode decode/;

#  処理の概要は ‥

# - 起動

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

    $in, @in;  # xml・sgml入力 
    @out;  # 出力xml 

=pod - 起動時オプション
        perl   mdevSGML_s2w.pl   入力sgml   [bds]
            b : ブロックの詳細出力あり
            d : デバグ用出力あり
            s : サンプルxmlの整形出力あり
=cut

# - サンプルxml  入力

    { #+ サンプルxmlを読む。
        # サンプルxmlを読む。
            # サンプルxmlを 'mdevSGML_sample.xml' から読む。
                getF_xml(  'mdevSGML_sample.xml' );
            # xml中の不要なタブを削除する。
                $in =~ s/\t+(?=<[^\?\/])//g;
                $in =~ s/(<\/[^>]*>[\x0d\x0a]*)\t+/$1/g;
                $in =~ s/(\/>\x0a?)\t+/$1/g;
            # タブと改行をエスケープする。
                $in =~ s/(\\)+[tn]/\\$&/g;
                $in =~ s/\t/\\t/g;
                $in =~ s/\x0d?\x0a/\\n/g;
            # タグ＋テキストの形に分ける。
                $in =~ s/<[^<>]*(?=<)/$&\t/g;
                $in =~ s/([^\x0a\t])(<)/$1\x0a$2/g;
                $in =~ s/\t//g;
            # 不要な改行を削除する。
                $in =~ s,>(\\n)+,>\\n,g;
                $in =~ s,(\\n)+\x0a,\x0a,g;
        # サンプルxmlを整形する。
            # 入力xml・sgmlを配列に変える。
                (  @in = split "\x0a",  $in  );
            # タブでインデントする。
                my $ind = 0; my $n = 0;
                for( @in ) {
                    my $i = $ind;
                    /^<\// && ( $i--, $ind-- ); /^<\w/ && $ind++; /\/>[^>]*$/ && $ind--;
                    $_ = ( "\t" x $i ).$_;
                }
            # 終了タグを１行にまとめる（ まとめられる場合 ）。
                my $i;
                for( $i = 0; $i + 1 < @in; $i++ ) {
                    $in[ $i ] =~ /^(?:\t)*<(?![\?\/])([^\s>]+)/ || next;
                    my $tag = $1;
                    $in[ $i + 1 ] =~ /^(?:\t)*(<\/$tag>)/ &&
                        ( $in[ $i ] .= $1, $in[ $i + 1 ] = "" );
                }
                @in = map do { $_ eq "" ? () : $_ }, @in;
            # DocumentPropertiesの不要タグ を省く。
                my @t = (
                    TotalTime, LastPrinted, Created, LastSaved, Version,
                    Pages, Words, Characters, Bytes, Lines, Paragraphs, CharactersWithSpaces,
                );
                my $t = "(".( join "|", @t ).")";
                @in = map do {
                    if( /<o:DocumentProperties>/ .. /<\/o:DocumentProperties>/ ) {
                        s/(<o:LastAuthor>).*?(<\/o:LastAuthor>.*)/$1 $2/;
                        s/(<o:Revision>).*?(<\/o:Revision>.*)/${1}1$2/;
                        /^\t*<o:$t>/ ? () : $_ ;
                    }
                    else { $_; }
                }, @in;
        # サンプルxmlの整形出力あり ならば サンプルxmlを整形出力する。
            if( $opt =~ /s/i ) { 
                # 出力xmlにサンプルxmlを挿入する。
                    @out = @in;
                # タブと改行をアンエスケープする。
                    for( @out ) { s/\\t/\t/g; s/\\n/\x0a/g; s/\\((\\)+[tn])/$1/g; }
                msg( '  out: sample_xml.txt' ); # メッセージ 
                # xmlを 'sample_xml.txt' に出力する。
                    putF_xml(  'sample_xml.txt' );
                msg( '  out: sample_lv1.txt' ); # メッセージ 
                # xmlの第1階層までを 'sample_lv1.txt' に出力する。
                    putF_Lv(  1,  'sample_lv1.txt' );
            }
    }

# - サンプルxml  ブロックに分割

    @parts;  { # ブロック 
        @parts = (
            'wordDocument',
            'DocumentProperties', 'CustomDocumentProperties',
            'fonts', 'lists', 'styles', 'docSuppData', 'shapeDefaults',
            'docPr', 'body',
        );
    }

    %delim;  { # 項目に分けるタグ 
        %delim = (
            'DocumentProperties' => 'o:DocumentProperties',
            'CustomDocumentProperties' => 'o:CustomDocumentProperties',
            'fonts'  => 'w:font',
            'lists'  => 'w:listDef',
            'styles' => 'w:style',
            'docSuppData' => 'w:docSuppData',
            'shapeDefaults' => 'w:shapeDefaults',
            'docPr' => 'w:docPr',
            'body' => 'w:body',
        );
    }

    { #+ サンプルxmlをブロックに分ける。
        # サンプルxmlをブロックに分ける。
            # for( @parts ) { ブロック $_ を読む。 }
                for( @parts ) { get_block(  $_ ) }
        # wordDocumentブロックを分割する。
            @wordDocument_end = ( pop @wordDocument );
            push @parts, 'wordDocument_end';
        # bodyを除く各ブロックを項目に分ける。
            # for( @parts ) { $_ eq 'body' || ブロック $_ を項目に分ける。 }
                for( @parts ) { $_ eq 'body' || sep_block(  $_ ) }
        # bodyを除く各ブロックの各項目にタイトルを付ける。
            # for( @parts ) { $_ eq 'body' || ブロック $_ の各項目にタイトルを付ける。 }
                for( @parts ) { $_ eq 'body' || titled(  $_ ) }
        # bodyブロックを項目に分ける。
            my $d = '(w:body|wx:sect|w:p|w:tbl|w:tr|w:tc)';
            my @b = ();
            my $t = "";
            for( @body ) {
                $t =~ /<\/$d>/ || /<$d[\s>]/ || ( $t .= "\x0a$_\\n", next );
                push @b, $t;
                $t = "\x0a$_\\n";
            }
            if( @b ) { push @b, $t; shift @b; }
            @body = @b;
        # bodyブロックを分割する。
            @body_end = ( join '', 'body end', pop @body );
            my $i = 0; for( @parts ) { /^body$/ && last; $i++; }
            splice( @parts, $i + 1, 0, 'body_end' );
        # bodyの各項目にタイトルを付ける。
            for( @body ) {
                /^\x0a/ || next;
                /^\x0a/ || next;
                my $s = /^\x0a(.*)\x0a/ ? $1 : $_ ;
                $s =~ /<\/?(?:\w*:)?([\w:]+)/; my $t = $1;
                my $m = ( $s =~ /\sw:name="([^"]*)"/  ) ? $1 :
                        ( /<w:name\s+w:val="([^"]*)"/ ) ? $1 :
                        ( $s =~ /<\// ) ? "- end" :
                        ( /<\/(\w*:)?$t[\s>]/ ) ? "- start .. end" : "- start" ;
                $t eq 'p' && /<w:sectPr[\s>]/ && ( $t .= ' sectPr' );
                $t eq 'p' && ( $m = join '', /<w:t>(.*)<\/w:t>/g );
                $t eq 'p' && ( $m .= "\t\t".chk_para( $_ ), $m =~ s/\t\t$// );
                $_ = "$t $m$_";
            }
    }

# - サンプルxml  ブロックを加工

    %styleId;  # スタイルIDのテーブル 
    @para_gaij;  # 機種既存文字の段落 
    @style_table;  # 表組のスタイル 

    { #+ ブロックを加工する。
        # stylesブロックから 表組のスタイルを読む。
            @style_table = ();
            my $n = 'Table Grid';
            for( @styles ) { /<w:name(?=\s).*?\sw:val="$n"/ && push @style_table, $_; }
        # ブロックから 不要の項目とタグを消す。
            # 'styles' から 'wx:uiName' タグのある項目を省く。
                pass1(  'styles',  'wx:uiName' );
            # 'styles' の各項目で 'w:rsid' タグを省く。
                delTag(  'styles',  'w:rsid' );
            # 'docPr' の各項目で 'wsp:rsids' タグを省く。
                delTag(  'docPr',  'wsp:rsids' );
            # 'docPr' の各項目で 'wsp:rsidRoot' タグを省く。
                delTag(  'docPr',  'wsp:rsidRoot' );
            # 'docPr' の各項目で 'wsp:rsid' タグを省く。
                delTag(  'docPr',  'wsp:rsid' );
            { # bodyで省略する属性。
                $dTag = 'w:(?:p|r|tr|sectPr)';
                $dProp ='wsp:(?:rsidP|rsidR|rsidRPr|rsidRDefault|rsidTr|rsidSect)';
            }
            # 'body' の各項目で $dTag タグの $dProp 属性を省く。
                delProp(  'body',  $dTag,  $dProp );
        # stylesブロックに 表組のスタイルを戻す。
            @styles && splice( @styles, @styles - 1, 0, @style_table );
        # stylesブロックから スタイルIDのテーブルを作る。
            %styleId = ();
            for( @styles ) {
                /<w:style(?=\s).*?\sw:styleId="([^"]*?)"/ || next;
                my $id = $1;
                /<w:name(?=\s).*?\sw:val="([^"]*?)"/ &&
                    ( $styleId{ utf8_to_cp932( $1 ) } = $id );
            }
        # bodyブロックから 機種既存文字の段落を読む。
            @para_gaij = ();
            my $n = $styleId{ '機種依存文字及び外字等の管理' };
            for( @body ) { /<w:pStyle(?=\s).*?\sw:val="$n"/ && push @para_gaij, $_; }

        # ブロックの詳細出力あり ならば ブロックをファイルに出力する。
            if( $opt =~ /b/i ) { 
                { # メッセージ
                    msg( '  out: parts_*.txt' );
                }
                #  for( @parts ) { ブロック $_ を "parts_$_.txt" に出力する。 }
                    for( @parts ) { putF_part(  $_,  "parts_$_.txt" ) }
                #  bodyを除く各ブロックのタイトルを 'parts_index.txt' に出力する。
                    putF_title(  'parts_index.txt' );
                #  bodyのタイトルを 'parts_body_index.txt' に出力する。
                    putF_body_title(  'parts_body_index.txt' );
            }
        # ブロックの詳細出力あり ならば bodyの未知タグ・未知属性を確認する。
            if( $opt =~ /b/i ) { 
                # bodyの未知タグ・未知属性を調べる。
                    chk_body();
                # ブロック 'unknown' を 'parts_body_unknown.txt' に出力する。
                    putF_part(  'unknown',  'parts_body_unknown.txt' );
            }

        @ins_mark;  # hidden, top, body の挿入マーク 
        { # bodyの内容を削除して  hidden, top, body の挿入マークに置き換える。
            { # bodyで残こしておくタグ。
                $dTag = '(?:w:body|\/?wx:sect|w:sectPr)';
            }
            # 'body' から $dTag タグのない項目を省く。
                pass2(  'body',  $dTag );
            # bodyに hidden, top, body の挿入マークを入れる。
                my $i = 0; my @s = (); my @p = (); my @i = ();
                for( @body ) {
                    /<wx:sect>/ && push @s, $i; /<w:p>/ && push @p, $i; $i++;
                }
                @ins_mark = ( '〓hidden〓', '〓top〓', '〓body〓' );
                @s > 1 && @p && ( @i = ( $s[ 0 ], $p[ 0 ], $s[ @s - 1 ] ) );
                    # 最初の wx:sect, 最初の w:p, 最後の wx:sect
                my @m = @ins_mark;
                for( reverse @i ) { splice( @body, $_ + 1, 0, "\t<!--".( pop @m )."-->" ); }
        }
    }

    @unknown;  # bodyの未知タグ・未知属性 

    $dTag, $dProp;  # 省略するタグと属性 

    sub putF_title { # bodyを除く各ブロックのタイトルを( fn )に出力する。 
        my $fn = $_[0]; # ファイル名 
        # ファイル $fn に '' を出力する。
            putF(  $fn,  '' );
        #  for( @parts ) { $_ eq 'body' || ブロック $_ のタイトルを $fn に追記する。 }
            for( @parts ) { $_ eq 'body' || addF_index(  $_,  $fn ) }
    }

    sub putF_body_title { # bodyのタイトルを( fn )に出力する。 
        my $fn = $_[0]; # ファイル名 
        # ファイル $fn に '' を出力する。
            putF(  $fn,  '' );
        # ブロック 'body' のタイトルを $fn に追記する。
            addF_index(  'body',  $fn );
    }

# - 出力xml  ひな形作成

    { #+ 出力xmlのひな形を作る。
        # 出力xmlにブロックを挿入する。
            @out = ();
            # for( @parts ) { 出力xmlにブロック $_ を挿入する。 }
                for( @parts ) { ins_parts(  $_ ) }

        #  ブロック 'body' を 'xml_body_1st.txt' に出力する。
    }

# - 入力sgml  入力

    { #+ sgmlを読む。
        # 入力sgmlを読む。
            (  $in = join '',  getF( $fn )  );
        # 入力sgmlを タグ＋テキスト の形に分ける。
            # タブと改行をエスケープする。
                $in =~ s/(\\)+[tn]/\\$&/g;
                $in =~ s/\t/\\t/g;
                $in =~ s/\x0d?\x0a/\\n/g;
            # 半角＆をエスケープする。
                $in =~ s/\&/&amp;/g;
            # 強制改行をタグに変える。
                $in =~ s/\&amp;enter;/<br>/g;
            # 終了タグを補う。
                my $tag = '(graphic|br)';
                $in =~ s/<($tag)(\s[^>]*)?>/$&<\/$1>/gi;
            # DOCTYPE宣言をエスケープする。
                while( $in =~ s/(<!DOCTYPE\s[^<>]*)<(![^>]*)>/$1&lt;$2&gt;/i ) {};
            # タグ＋テキストの形に分ける。
                $in =~ s/<[^<>]*(?=<)/$&\t/g;
                $in =~ s/([^\x0a\t])(<)/$1\x0a$2/g;
                $in =~ s/\t//g;
        # 入力sgmlの書式を揃える。
            # 属性の記述を統一する。
                $in =~ s,(<[\w-]+)\s+,$1 ,g;
                while( $in =~ s,(<[\w-]+[^>]*)\s+=,$1=,i ) {};
                while( $in =~ s,(<[\w-]+[^>]*)=\s+,$1=,i ) {};
            # 定型の属性を削除する。
                my @tag =( 'Warning', 'Contraindication-and-Prohibitions', );
                my $col = '(red|black)';
                for ( @tag ) {
                    $in =~ s,<$_ boxline="yes" boxcolor="rd" color="$col">,<$_>,gi;
                }
            # 不要な属性を削除する。
                $in =~ s,<variablelabel onswitch="off">,<variablelabel>,gi;
                $in =~ s,<serialno onoff="on">,<serialno>,gi;
            # 不要な改行を削除する。
                $in =~ s,>(\\n)+,>\\n,g;
                $in =~ s,(\\n)+\x0a,\x0a,g;
            # variablelabelタグの属性を追加する。
                my @a = (
                    'Company-identifier',
                    'Download',
                    'The-permission-number-of-business-condition',
                    'Name-of-manufacturer',
                    'Address-of-manufacturer',
                    'The-recognition-number-of-business-condition',
                    'Phonenumber-of-manufacturer',
                    'Name-of-oversea-manufacturer',
                    'Address-of-oversea-manufacturer',
                    'The-authorization-number-of-business-condition',
                    'Phonenumber-of-oversea-manufacturer',
                    'The-company-name-of-specification-into-English',
                    'Address-of-specification-into-English',
                    'The-country-code',
                    'Name-of-a-country',
                );
                my $a = "(?:".( join "|", @a ).")";
                $in =~ s/(<$a>\s*<variablelabel)(>)/$1 onswitch="on"$2/gi;
            # variablelabelタグを属性に変える。
                $in =~ s/(>)\s*(<variablelabel[\s>])/$1$2/gi;
                $in =~ s/(<\/variablelabel>)\s*(?!<)/$1/gi;
                $in =~ s/<variablelabel>\s*<\/variablelabel>//gi;
                $in =~ s/<variablelabel\s[^>]*>\s*<\/variablelabel>//gi;
                $in =~ s/<([^>]*)>\s*<(variablelabel)>([^<]*\S)\s*<\/\2>/<$1 $2-off="$3">/gi;
                $in =~ s/<([^>]*)>\s*<(variablelabel)\s[^>]*>([^<]*\S)\s*<\/\2>/<$1 $2="$3">/gi;
            # 不要の itemタグと detailタグを削除する。
                $in =~ s/<(item|detail)(\s+variablelabel-off="[^"]*")?>\s*<\/\1>\s*//gi;
            # 変換できない serialnoタグを表示する。
                my @t =( $in =~ /<serialno(?=[\s>]).*?>\s*((?:.|\s)*?)<\/serialno>/gi );
                @t = map do { s/\x0a//g; /^\d*\s*$/ ? () : $_ }, @t;
                @t && msg( '  変換できない serialnoタグ：', map do { "    $_" }, @t );
            # serialnoタグを次のタグの属性に変える。
                $in =~ s/<serialno\s+onoff\s*=\s*"off"[^<]*<\/serialno>\s*//gi;
                $in =~ s/<serialno\s+onoff\s*=\s*"on"\s*/<serialno /gi;
                $in =~ s/\x0a?(<\/serialno>)\s*(?=<)/$1/gi;
                my ( $as, $ae ) = ( '\s*<chr>\s*<bold>\s*', '\s*<\/bold>\s*<\/chr>\s*' );
                ( $as, $ae ) = map do { "(?:$_)?"; }, ( $as, $ae );
                $in =~ s/<(serialno)(.*?)>$as([^<\s]*)$ae<\/serialno><([\w-]+)/<$4 $1="$3"/gi;
            # linkタグを属性に変える。
                $in =~ s/(>)\s*(<link[\s>])/$1$2/gi;
                $in =~ s/(<\/link>)\s*(?!<)/$1/gi;
                $in =~ s/<link>\s*<\/link>//gi;
                $in =~ s/<([^>]*)>\s*<(link)>([^<]*\S)\s*<\/\2>/<$1 $2="$3">/gi;
            # detail内のtableを分離する。
                my $at = '('.( join '|', qw( chem chr graphic br url ) ).')';
                my $s = '';
                while( $in =~ /(<tblblock(?=[\s>])[^>]*>(?:.|\s)*?<\/tblblock>)/ ) {
                    my ( $p, $q, $r ) = ( $`, '', $& ); $in = $';
                    while( $p =~ /^((?:.|\s)*)(<(?![\s!-])[^<]*)$/ ) {
                        ( $p, $q ) = ( $1, $2.$q );
                        $q =~ /^<\/?$at[\s>]/ || last;
                    }
                    $q =~ /^<\// && ( $s .= "$p$q$r", next );
                    $s .= $p;
                    $q =~ /^<(\S+)/; my $t = $1;
                    $s .= ( $q =~/^<$t(\s+variablelabel-off="[^"]*")?>\s*$/ ) ?
                              "$q$r" : "$q</$t>\x0a$r" ;
                    my $x = "\x0a<$t>"; $in =~ /^(\s*)<\/$t>/ && ( $in = $', $x = $1 );
                    $s .= $x;
                }
                $in = $s.$in;
            # simpletableのセル数を数える。
                while( $in =~ /<simpletable>/ ) {
                    my ( $p, $q, $r ) = ( $`, $&, $' );
                    $r =~ /<simptblrow>((?:.|\s)*?)<\/simptblrow>/; my $s = $1;
                    my @r = ( $s =~ /<simptblcell(?=[\s>])([^>]*)>/g );
                    @r = map do { /cspan="0*(\d+)"/ ? $1 : 1 }, @r;
                    my $c = 0; for( @r ) { $c += $_; }
                    $in = $p.'<simpletable columns="'.$c.'">'.$r;
                }
        # デバグ用出力あり ならば msg( '  out: chk_*.txt' );
            if( $opt =~ /d/i ) {  msg( '  out: chk_*.txt' ); }
        # デバグ用出力あり ならば 入力xml・sgmlを 'chk_sgm1.txt' に出力する。
            if( $opt =~ /d/i ) { putF(  'chk_sgm1.txt',  $in  ); }
    }

# - 変換規則  入力

    @s2w;  { # 変換規則を読む。 
        # 変換規則を 'mdevSGML_s2w.txt' から読む。
            getF_s2w(  'mdevSGML_s2w.txt' );
    }
    %tag2name;  { # タグをタグ名に置換するテーブルを作る。
        # タグをタグ名に置換するテーブルを作る。
            %tag2name = ();
            for( @s2w ) {
                /^(　)*(.*?)\s+\/\s+(.*\S)/ || next;
                $tag2name{ lc( "<$3>" ) } = ( $2 eq "" ) ? $3 : $2 ;
            }
    }
    @tag;  { # 変換規則から タグのリストを作る。
        # 変換規則から タグのリストを作る。
            my @t = map do { ! /^\t/ && /\s\/\s+(.*\S)/ ? $1 : () }, @s2w;
            my %t = map do { ( lc( "<$_>" ) => 1 ); }, @t;
            @tag = sort keys %t;
    }
    %tag2num;  { # タグのリストから タグをタグ番号に置換するテーブルを作る。
        # タグのリストから タグをタグ番号に置換するテーブルを作る。
            %tag2num = ();
            my $n = 1; for( @tag ) { $tag2num{ $_ } = sprintf "%03d", $n++; }

        # デバグ用出力あり ならば タグをタグ番号に置換するテーブルを 'chk_tag2num.txt' に出力する。
            if( $opt =~ /d/i ) { putF_tag2num(  'chk_tag2num.txt' ) }
    }

    %path2xml;  { # sgmlのタグ列を xmlのタグに置換するテーブル 
        # 変換規則内のタグを タグ番号に変える。
            for ( @s2w ) {
                /^(?!\t)((?:　)*).*\/\s*(.*\S)\s*$/ || next;
                my ( $s, $t ) = ( $1, $2 );
                $_ = $s.'<'.$tag2num{ lc( "<$t>" ) }.'>';
           }
        # 変換規則内の全角空白によるインデントを タグ列に変える。
            my @t = ();
            for( @s2w ) {
                /^\t/ && next;
                my @s = /　/g; my @n = /<[^>]+>/g;
                splice( @t, scalar @s, @t - @s, @n );
                $_ = join "", @t;
            }
        # 変換規則内の 行頭がタブで始まる行を 前の行に連結する。
            my @w = map do { /^\t/ ? $_ : $_."\t" ; }, @s2w;
            my $s2w = join "\x0a", @w;
            $s2w =~ s/\x0a+\t\t//g;
            @s2w = split "\x0a", $s2w;
        # sgmlのタグ列を xmlのタグに置換するテーブル を作る。
            %path2xml = map do { /\t+/ ? ( $` => [ $' ] ) : () ; }, @s2w;
        # 開始タグ・中区切・終了タグ・属性の それぞれに対応する部分に分ける。
            for( keys %path2xml ) {
                my $s  = @{$path2xml{ $_ }}[0];
                my ( $st, $sp, $et ) = ( "", "", "" ); my @p = ();
                while( $s =~ /〓.*?(〓|：|$)/ ) {
                    $st .= $`; my $p = $&; $s = $';
                    $1 eq '〓' && ( $st .= $p, next );
                    $s =~ /(〓|$)/; push @p, $p.$`; $s = $&.$';
                }
                $st .= $s;
                $st =~ /(\.\.\.)(.*?)\.\.\./ && ( $st = $`.$1.$', $sp = $2 );
                $st =~ /\.\.\./ && ( $st = $`, $et = $' );
                for( $st, $sp, $et ) { s/\t//g; }
                $path2xml{ $_ } = [ $st, $sp, $et, $_, @p ];
            }
        # 属性の置換テーブルを作る。
            for( keys %path2xml ) {
                my ( $t, @p ) = splice( @{$path2xml{ $_ }}, 3 );
                $t =~ /^(<\d+>)*<\/?(\d+)>/; my $sn = $tag2name{ $tag[ $2 - 1 ] };
                @{$path2xml{ $_ }}[0] =~ /-style：(.*?)-/ &&
                    ( $sn = $1, @{$path2xml{ $_ }}[0] = $`.$' );
                my $p = {
                   'variablelabel' => [ '.*=>$&' ], 'variablelabel.style' => [ $sn ],
                };
                for( @p ) {
                    /^〓[@]?([@]?.*?)：/ || next;
                    my ( $k, $v ) = ( $1, $' );
                    $v =~ /\t-style：(.*?)-/ && ( $v = $', $p->{ $k.'.style' } = [ $1 ] );
                    @v = ( $v =~ /\t.*?=>\t*[^\t]*/g );
                    @v = map do { s/^\t//; s/\$nul\s*$//; /\t*=>\t*/; "$`=>$'"; }, @v;
                    $p->{ $k } = [ @v ];
                }
                push @{$path2xml{ $_ }}, $p;
            }

        # デバグ用出力あり ならば 変換規則を 'chk_cnv.txt' に出力する。
            if( $opt =~ /d/i ) { putF(  'chk_cnv.txt',  join "\x0a",  @s2w,  ""  ); }
        # デバグ用出力あり ならば xmlのタグに置換するテーブルを 'chk_path2xml.txt' に出力する。
            if( $opt =~ /d/i ) { putF_path2xml(  'chk_path2xml.txt' ) }
    }

# - 入力sgml  変換の準備

    { #+ 変換の準備をする。
        # 入力sgmlを タグ列＋テキスト の形に変える。
            # 入力xml・sgmlを配列に変える。
                (  @in = split "\x0a",  $in  );
            # タブでインデントする。
                my $ind = 0; my $n = 0;
                for( @in ) {
                    my $i = $ind;
                    /^<\// && ( $i--, $ind-- ); /^<\w/ && $ind++; /\/>[^>]*$/ && $ind--;
                    $_ = ( "\t" x $i ).$_;
                }
            # 未知のタグを確認する。
                my @u = map do { /<\w[^>]*>/g; }, @in;
                @u = map do { /^<[^\s>]*/; defined( $tag2num{ lc( "$&>" ) } ) ? () : $_ }, @u;
                my %u = map do { ( $_ => 1 ) }, @u;
                @u && msg( '  未知のタグがありました。', map do { "    $_" }, sort keys %u );
            # タグを タグ番号に置換する。
                for ( @in ) {
                    s/<(\w[^\s>]*)\s*/<$tag2num{ lc( "<$1>" ) }></; s/<>//;
                    s/<\/(\w[^>]*)>/<\/$tag2num{ lc( "<$1>" ) }>/;
               }
            # 終了タグの終わりの文字列を確認する。
                my @u = map do {
                    /^(　)*(<\d+>)*<\/\d+>(.*?>)?(\s|\\n)*/ && $' ne "" ? $_ : ()
                }, @in;
                @u &&
                    msg( '  終了タグの終わりに文字列がありました。', map do { "    $_" }, @u );
            # インデントをタグ列に変える。
                my @t = ();
                for( @in ) {
                    /^(\t)*(<[^>]+>)*/; my ( $t, $r ) = ( $&, $' );
                    my @s = ( $t =~/\t/g ); my @n = ( $t =~ /<[^>]+>/g );
                    splice( @t, scalar @s, @t - @s, @n );
                    $_ = join "", @t, $r;
                }

        # 入力xml・sgmlを文字列に戻す。
            (  $in = join "\x0a",  @in,  ""  );
        # デバグ用出力あり ならば 入力xml・sgmlを 'chk_sgm2.txt' に出力する。
            if( $opt =~ /d/i ) { putF(  'chk_sgm2.txt',  $in  ); }
    }

    @cat, %cat;  { # 類別 と 類別のテーブル 
        # 類別を 'mdevSGML_cat.txt' から読む。
            getF_cat(  'mdevSGML_cat.txt' );
        # 類別のテーブルを作る。
            %cat = ();
            map do { s/^\s*//; s/\s*$//; /\t+/ && ( $cat{ $` } = [ $' ] ); }, @cat;
    }

    @country, %country;  { # 国名 と 国名のテーブル 
        # 国名を 'mdevSGML_country.txt' から読む。
            getF_country(  'mdevSGML_country.txt' );
        # 国名のテーブルを作る。
            %country = ();
            map do { s/^\s*//; s/\s*$//; /\t+/ && ( $country{ $` } = [ $' ] ); }, @country;
    }

# - 出力xml  変換

    @hidden;  { # 表示されない情報
        # 表示されない情報
            @hidden = ();
    }
    @hide;  { # 表示する情報かどうかの判断の保持
        # 表示する情報かどうかの判断の保持
            @hide = ();
    }
    $top_prop;  { # 冒頭の情報の抽出結果
        # 冒頭の情報の抽出結果
            $top_prop = {};
    }
    @pare;  { # タグの属性の保持
        # タグの属性の保持
            @pare = ();
    }
    $w_w;  { # 表組のセル幅の保持
        # 表組のセル幅の保持
            $w_w = 0;
    }
    @span_p, @span_n;  { # 表組のrowspanの保持
        # 表組のrowspanの保持
            @span_p = (); @span_n = ();
    }
    %atr_tag;  { # 文字属性タグの変換テーブル
        # 文字属性タグの変換テーブル
            my %a = (
                'bold'   => '<w:b/>',
                'italic' => '<w:i/>',
                'under'  => '<w:u w:val="single"/>',
                'sup'    => '<w:vertAlign w:val="superscript"/>',
                'sub'    => '<w:vertAlign w:val="subscript"/>',
                'chem'   => '',
                'div'    => '',
                'nom'    => '',
                'den'    => '',
                'han'    => '',
                'gaiji'  => '<w:rStyle w:val="affffffffd"/>',
            );
            %atr_tag = ();
            for( keys %a ) { $atr_tag{ $tag2num{ "<$_>" } } = $a{ $_ }; };
    }
    %cols;  { # 色の変換テーブル
        # 色の変換テーブル
            %cols = (
                'red' => 'FF0000',
            );
    }
    @not_conv;  { # 変換されなかった情報
        # 変換されなかった情報
            @not_conv = ();
    }

    { #+ 変換する。
        # bodyブロックを 初期化する。
            @body = ();
        # 入力sgmlに タグ列をxmlのタグに置換する処理 を繰り返す。
            for( @in ) { 
                my $t, $p, $r;  { # タグ列・属性・テキストに分離する。
                    # タグ列・属性・テキストに分離する。
                        /[^>]*$/; ( $t, $r ) = ( $`, $& );
                        $t =~ /^(<\d+>)*<\/?\d+>/; $t = $&; $p = $';
                }
                my $c;  { # タグ列に対応する変換テーブルを読む。
                    # タグ列に対応する変換テーブルを読む。
                        $c = path_conv( $t );
                    # タグ列に対応する変換テーブルがないとき 次へ。
                        $c || next;
                }
                my $st, $sp, $et, $pr;  { # 開始タグ・タグ間・終了タグに対応するxmlのタグ と 属性の変換テーブル を取り出す。
                    # 開始タグ・タグ間・終了タグに対応するxmlのタグ と 属性の変換テーブル を取り出す。
                        ( $st, $sp, $et, $pr, ) = map do { s/^\t+//; $_; }, @$c;
                }
                my $isStart;  { # 開始タグか？
                    # 開始タグか？
                        $isStart = ( $t =~ /<\d+>$/ );
                }
                my $hide;  { # 表示する情報か？
                    # 表示する情報か？
                        $hide = ( $st =~ /-to：hx-/ ) ? @hide && $hide[ 0 ] : $st =~/-to：h-/ ;
                        if( $isStart ) { unshift @hide, $hide; } else { shift @hide; }
                        $st =~ s/-to：hx?-//;
                }
                my $head;  { # 冒頭の情報か？
                    # 冒頭の情報か？
                        $head = ( $st =~ /-to：tx-/ ) ? @head && $head[ 0 ] : $st =~/-to：t-/ ;
                        if( $isStart ) { unshift @head, $head; } else { shift @head; }
                        $st =~ s/-to：tx?-//;
                }
                my $prop, $pare;  { # タグの属性・親タグの属性
                    # タグの属性・親タグの属性
                        $isStart && unshift @pare, prop_get( $p );
                        $prop = $pare[ 0 ];
                        $pare = @pare > 1 ? $pare[ 1 ] : {} ;
                        $isStart || shift @pare;
                }
                my $isPara, $inPara;  { # 段落か？
                    # 段落か？
                        $isPara = ( $st =~ /-para-/ ); $st =~ s/-para-//;
                }
                my $free;  { # 自由書式か？
                    # 自由書式か？
                        $free = ( $st =~ /-f-/ ); $st =~ s/-f-//;
                }
                # 冒頭の情報を抽出する。
                    $head && $t =~ /<(\d+)>$/ && defined( $tag[ $1 - 1 ] )  && do {
                        my $tn = $tag[ $1 - 1 ];
                        $tn =~ /^<(item|detail)>$/ &&
                            ( $t =~ /<(\d+)><\d+>$/, $tn = $tag[ $1 - 1 ].$tn );
                        $tn =~ /^<(year-month|version)>$/ && do {
                            my $n = 1; while( defined( $top_prop->{ "$1/$n" } ) ) { $n++ }
                            $tn = "$1/$n";
                        };
                        my $f = $tn; $f =~ s/^<//; $f =~ s/>$//; $f =~ s/></\//;
                        my $p = { '...' => $r }; for( keys %$prop ){ $p->{ $_ } = $prop->{ $_ }; }
                        $top_prop->{ $f } = $p;
                    };
                # タグの属性を補正する。
                      $isStart && ( $st = prop_conv( $st, $prop, $pr, $pare ) );
                    ! $isStart && ( $et = prop_conv( $et, $prop, $pr, $pare ) );
                # 表組のセル幅を調べる。
                    my $tr = $tag2num{ "<simpletable>" };
                    $t =~ /<$tr>$/ && do {
                        my $c = ( $p =~ /[<\s]columns="(\d+)"/ && $1 ) ? $1 : 1 ;
                        my $width = 1186 * 4; $w_w = int( $width / $c + 0.5 );
                    };
                # 表組のrowspanを調べる。
                    my $tr = $tag2num{ "<simptblrow>" };
                    $t =~ /<$tr>$/ && do {
                        @span_p = @span_n; @span_n = ();
                        for( @span_p ) { $$_[0]--; }
                    };
                # テキストを補正する（ テキストと文字属性 ）。
                    $isStart && $st =~ /^(-\w+-)*\$nul$/ && ( $r = "" );
                    ! $isStart && $r =~ /^\s*$/ && ( $r = "" );
                    $prop->{ '...' } = $r;
                    $isStart && defined( $pr->{ '...' } ) && $r ne "" &&
                        ( $r = prop_alt( '...', $prop, $pr ) );
                    my $sn = @{$pr->{ 'variablelabel.style' }}[0];
                    $isPara && $isStart && $sn ne "" && pStyle( $sn, $p ) ne "" && ( $inPara = 1 );
                    $inPara && $r ne "" && ( $r = join '', (
                        '<w:r>', rStyle( $t ), '<w:t>', $r, '</w:t>', '</w:r>',
                    ) );
                    $inPara && $isStart && defined( $prop->{ 'serialno' } ) &&
                        ( $r = rList( $t, $prop ).$r );
                # テキストを補正する（ 強制改行 ）。
                    my $b = '<'.$tag2num{ "<br>" }.'>';
                    $inPara && $r eq "" && $t =~ /$b$/ && ( $r = join '', (
                        '<w:r>', '<w:br/>', $r, '</w:r>',
                    ) );
                # テキストを補正する（ 画像 ）。
                    my $g = '<'.$tag2num{ "<graphic>" }.'>';
                    my ( $w, $h );
                    $inPara && $r eq "" && $t =~ /$g$/ && $p =~ /<gfname="([^"]*)">/ && (
                        ( $w, $h ) = getS( $1 ),
                        $r = join '', (
                            '<w:r>', '<w:pict>',
                            '<v:shape type="#_x0000_t75" style="width:'.$w.'pt;height:'.$h.'pt">',
                            '<v:imagedata src="'.$1.'"/>', '</v:shape>',
                            '</w:pict>', '</w:r>',
                        )
                    );
                # テキストを補正する（ 段落属性 ）。
                    $inPara && $isPara && ! $isStart && ( $r .= '</w:p>', $inPara = 0 );
                    $inPara && $isPara && ( $r = join '', ( '<w:p>', pStyle( $sn, $p ), $r, ) );
                    $inPara && $isPara && $isStart && defined( $prop->{ 'serialno' } ) &&
                        $r =~ s/<\/w:pPr>/<w:ind w:hanging-chars="120"\/>$&/;
                # テキストを補正する（ 表組 ）。
                    my $tb = $tag2num{ "<simpletable>" };
                    $t =~ /<$tb>$/   && ( $r = join '', (
                        '<w:tbl>',
                        '<w:tblPr>', '<w:tblStyle w:val="'.$styleId{ 'Table Grid' }.'"/>',
                        '<w:tblW w:w="0" w:type="auto"/>', '</w:tblPr>', $r,
                    ) );
                    $t =~ /<\/$tb>$/ && ( $r .= '</w:tbl>' );
                    my $tr = $tag2num{ "<simptblrow>" };
                    $t =~ /<$tr>$/   && ( $r = join '', ( '<w:tr>', $r, ) );
                    $t =~ /<\/$tr>$/ && ( $r .= '</w:tr>' );
                    my $tc = $tag2num{ "<simptblcell>" };
                    $t =~ /<$tc>$/   && ( $r = join '', (
                        chk_rowspan( $p ),
                        '<w:tc>', '<w:tcPr>', '<w:tcW w:w="'.$w_w.'" w:type="dxa"/>',
                        '<w:shd w:val="clear" w:color="auto" w:fill="auto"/>',
                        ( $p =~ /[<\s]rspan="0*(\d+)"/ && 1 < $1 ? '<w:vmerge w:val="restart"/>' :
                            () ),
                        ( $p =~ /[<\s]cspan="0*(\d+)"/ && 1 < $1 ? '<w:gridSpan w:val="'.$1.'"/>' :
                            () ),
                        ( $p =~ /[<\s]valign="bottom"/ ? '<w:vAlign w:val="bottom"/>' :
                          $p =~ /[<\s]valign="top"/ ? () : '<w:vAlign w:val="center"/>' ),
                        '</w:tcPr>', $r,
                    ) );
                    $t =~ /<\/$tc>$/ && ( $r .= '</w:tc>' );
                # 変換されなかった情報を確認する。
                    $r ne '' && ! $head && ! ( $r =~ /<\/?[\w:-]+[>\s]/ ) &&
                        ( ( push @not_conv, [ $t, $r ] ), $r = '');
                # 変換結果を保存する。
                    $r = cp932_to_utf8( $isStart ? "$st$r" : "$r$et" );
                    $r ne '' &&   $hide && push @hidden, "\t$r";
                    $r ne '' && ! $hide && ! $head && push @body, "\t$r";
                # テキストを追加する（ 自由書式のとき ）。
                    $free && ! $isStart && push @body, cp932_to_utf8( join '', (
                        '<w:p>', pStyle( '自由書式' ),
                        '<w:r>', rStyle( '' ), '<w:t>　</w:t>', '</w:r>',
                        '</w:p>'
                    ) );
            }
        # 機種既存文字の段落を hidden に追加する。
            push @hidden, @para_gaij;
        # 行の高さを補正する。
            my $s = join "\x0a", @body; my $body = '';
            while( $s =~ /<w:p>(.|\s)*?<\/w:p>/ ) {
                my $q = $&; $s = $'; $body .= $`;
                my @q = ( $q =~ /(<v:shape\s[^>]*>)/g );
                @q = map do { /style=".*?;height:([\d.]+)pt"/ ? $1 : () }, @q;
                my $h = 0; for( @q ) { $_ > $h && ( $h = $_ ); }
                $h = int( $h + 0.5 );
                @q && $q =~ s/<\/w:pPr>/<w:spacing w:line="$h"\/>$&/;
                $body .= $q;
            }
            $body .= $s;
            @body = split "\x0a", $body;
        # セルの高さを補正する。
            my $s = join "\x0a", @body; my $body = '';
            while( $s =~ /<w:tr[\s>](?:.|\s)*?<\/w:tr>/ ) {
                my $tc = $&; $s = $'; $body .= $`;
                my @tc = ( $tc =~ /(<w:pPr[\s>](?:.|\s)*?<\/w:pPr>)/g );
                @tc = map do { /<w:spacing w:line="([^"]*)"\/>/ ? $1 : () }, @tc;
                my $h = 0; for( @tc ) { $_ > $h && ( $h = $_ ); }
                $h = int( $h + 0.5 ); $h *= 20;
                @tc && $h > 0 && do {
                    $tc =~ /<w:trPr>/ ||
                        $tc =~ s/<w:tr(?=[\s>])[^>]*>/$&<w:trPr><\/w:trPr>/;
                    $tc =~ s/<\/w:trPr>/<w:trHeight w:h-rule="exact" w:val="$h"\/>$&/;
                    $tc =~ s/<w:spacing w:line="([^"]*)"\/>//g;
                };
                $body .= $tc;
            }
            $body .= $s;
            @body = split "\x0a", $body;
        # 変換されなかった情報を表示する。
            my @at = qw(
                chr bold italic under sup sub chem div nom den han gaiji graphic br
            );
            my $at = '(?:'.( join '|', @at ).')';
            for( @not_conv ) {
                $$_[0] =~ /<([^>]*)>(?:<$at(?=[\s>])[^>]*>|<\/[^>]*>)*$/;
                $1 > 0 && ( $$_[0] = $tag[ $1 - 1 ] );
            }
            @not_conv = map do{ "    $$_[0]：$$_[1]" }, @not_conv;
            @not_conv && msg( '  変換されなかった情報：', @not_conv );

        # デバグ用出力あり ならば msg( '  out: xml_*.txt' );
            if( $opt =~ /d/i ) {  msg( '  out: xml_*.txt' ); }
        # デバグ用出力あり ならば ブロック 'hidden' を 'xml_hidden.txt' に出力する。
            if( $opt =~ /d/i ) { putF_part(  'hidden',  'xml_hidden.txt' ) }
        # デバグ用出力あり ならば ブロック 'body' を 'xml_body.txt' に出力する。
            if( $opt =~ /d/i ) { putF_part(  'body',  'xml_body.txt' ) }
    }

# - 出力xml  冒頭の情報

    @top;  # 冒頭の情報 
    $top_cnv;  # 冒頭の情報の変換テーブル 

    { #+ 冒頭の情報を作成する。
        # 冒頭の情報を 'mdevSGML_s2w_top.txt' から読む。
            getF_top(  'mdevSGML_s2w_top.txt' );
        # 冒頭の情報の変換テーブルを作る。
            my $t = join "\x0a", @top;
            $t =~ /(^|\x0a)\t*〓.*?：/ && ( ( @top = split "\x0a", $` ), $t = $&.$' );
            @top = map do { /^\t\t/ ?  $' : () }, @top;
            my @t = ();
            while( $t =~ /(?:^|\x0a)(\t*〓.*?：(?:.|\s)*?)(\x0a\t*〓.*?：|$)/ ) {
                push @t, $1; $t = $2.$';
            }
            @t = map do { s/(^|\x0a)\t\t/$1/g; $_; }, @t;
            $top_conv = {};
            for( @t ) {
                /^〓(.*?)：/ || next;
                my ( $k, $v ) = ( $1, $' );
                $v =~ /\t(-.*-)/ &&
                     ( $v = $', $top_cnv->{ $k.'.style' } = [ $1 ] );
                my @v = ( $v =~ /\t.*?=>\t*[^\t]*/g );
                @v = map do { /\t*=>\t*/; "$`=>$'"; }, @v;
                for( @v ) { s/^\t//; s/\$nul\s*$//; s/\s*$//; }
                $top_cnv->{ $k } = [ @v ];
            }
        # 冒頭の情報を変換する。
            my $top = join "\x0a", @top;
            while( $top =~ /〓(.*?)〓/ ) {
                my $k = $1; my ( $pre, $post ) = ( $`, $' );
                my $v = ( $k =~ /^\#/ ) ? '' :
                        ( $k =~ /\@/  ) ? $top_prop->{ $` }->{ $' } :
                                          $top_prop->{ $k }->{ '...' } ;
                my @c = defined( $top_cnv->{ $k } ) ? @{$top_cnv->{ $k }} : () ;
                for( @c ) {
                    /=>/ || next;
                    my ( $c, $r ) = ( $`, $' );
                    $v =~ /^$c$/i || next;
                    my @v = ( $&, $1, $2, $3, $4, $5, $6, $7, $8, $9 );
                    $r =~ s/\$&/$v[ 0 ]/g; for( 1 .. 9 ) { $r =~ s/\$$_/$v[ $_ ]/g; }
                    $r =~ s/cat\(\s*(\S+)\s*\)/@{$cat{ $1 }}[0]/g;
                    $v = $r; last;
                }
                $v ne '' && ( $v = join '', (
                    '<w:r>', rStyle( '' ), '<w:t>', $v, '</w:t>', '</w:r>',
                ) );
                my $s = defined( $top_cnv->{ $k.'.style' } ) ?
                            @{$top_cnv->{ $k.'.style' }}[0] : '';
                if( $s =~ /-style：(.*?)-/ ) {
                    $v = join '', ( '<w:p>', pStyle( $1, $s ), $v, '</w:p>', );
                }
                else { $pre =~ /(<\/w:p>)(\s*)$/ && ( $pre = $`.$2, $v .= $1 ); }
                $top = $pre.cp932_to_utf8( $v ).$post;
            }
            @top = split "\x0a", $top;

        # デバグ用出力あり ならば ブロック 'top' を 'xml_top.txt' に出力する。
            if( $opt =~ /d/i ) { putF_part(  'top',  'xml_top.txt' ) }
    }

# - 出力xml  出力

    { #+ 出力する。
        # hidden, top, body を挿入マークと置換する。
            my $i = 0; my %i = (); my @m = @ins_mark;
            for( @out ) {
                /<!--(.*?)-->/ && do { for( @m ) { $_ eq $1 && ( $i{ $_ } = $i ); } };
                $i++;
            }
            sub i { $i{ $b } <=> $i{ $a } }
            for( sort i @m ) { /〓(.*?)〓/ && splice( @out, $i{ $_ }, 1, @{$1} ); }
        # タブと改行をアンエスケープする。
            for( @out ) { s/\\t/\t/g; s/\\n/\x0a/g; s/\\((\\)+[tn])/$1/g; }
        # xmlを出力する。
            putF_xml();

        # デバグ用出力あり ならば xmlを 'xml.txt' に出力する。
            if( $opt =~ /d/i ) { putF_xml(  'xml.txt' ); }
    }

#  処理の詳細 ‥

# - 開始

# - サンプルxml・入力sgml

    sub getF_xml { # サンプルxmlを( fn )から読む。 
        -f $_[0] || err( '  xmlファイルがありません。' );
        $in = join '', getF( $_[0] );
    }

# - 類別・国名

    sub getF_cat { # 類別を( fn )から読む。 
        -f $_[0] || err( '  類別のファイルがありません： '.$_[0] );
        @cat = getF( $_[0] );
    }

    sub getF_country { # 国名を( fn )から読む。 
        -f $_[0] || err( '  国名のファイルがありません： '.$_[0] );
        @country = getF( $_[0] );
    }

# - エスケープ と アンエスケープ

# - タグの整形    タグ列

# - タグの整形    属性

# - ブロック

    sub get_block { # ブロック( array )を読む。 
        my $t = $_[0];
        $t eq 'wordDocument' && return get_wordDocument();
        my $s = ( $delim{ $_[0] } =~ /^\w+:/ ) ? $& : "" ;
        @{"$_[0]"} = map do {
            /^(\t)*<$s$t[\s>]/ .. /^(\t)*<\/$s$t[\s>]/ ? $_ : () ;
        }, @in;
    }

    sub sep_block { # ブロック( array )を項目に分ける。 
        my @w = ();
        my $d = $delim{ $_[0] }; defined( $d ) || return;
        my $s = ( $delim{ $_[0] } =~ /^\w+:/ ) ? "$&$_[0]" : "" ;
        $s ne $d && ( $d = "($d|$s)" );
        my $t = "";
        for( @{$_[0]} ) {
            $t =~ /<\/$d>/ || /<$d[\s>]/ || ( $t .= "\x0a$_\\n", next );
            push @w, $t;
            $t = "\x0a$_\\n";
        }
        if( @w ) { push @w, $t; shift @w; }
        @{$_[0]} = @w;
    }

    sub titled { # ブロック( array )の各項目にタイトルを付ける。 
        for( @{$_[0]} ) {
            /^\x0a/ || next;
            my $s = /^\x0a(.*)\x0a/ ? $1 : $_ ;
            $s =~ /<\/?(?:\w*:)?([\w:]+)/; my $t = $1;
            my $m = ( $s =~ /\sw:name="([^"]*)"/  ) ? $1 :
                    ( /<w:name\s+w:val="([^"]*)"/ ) ? $1 :
                    ( $s =~ /\sw:listDefId="([^"]*)"/  ) ? $1 :
                    ( $s =~ /<\// ) ? "- end" :
                    ( /<\/(\w*:)?$t[\s>]/ ) ? "- start .. end" : "- start" ;
            $_ = "$t $m$_";
        }
    }

    sub putF_part { # ブロック( array )を( fn )に出力する。 
        putF( $_[1], join "\x0a", @{$_[0]}, "" );
    }

    sub addF_index { # ブロック( array )のタイトルを( fn )に追記する。 
        my $n = $_[0];
        my @t = map do { "\t".utf8_to_cp932( /\x0a/ ? $` : $_ ) }, @{$_[0]};
        unshift @t, "$n /";
        $n eq 'body' && ( @t = map do { s/^.*?(?=\t\t)/$&\x0a/; $_; }, @t );
        addF( $_[1], join "\x0a", @t, "" );
    }

# - ブロック  wordDocument

    sub get_wordDocument { # wordDocumentブロックを読む。 
        my @w = map do {
            /^</ || /^(\t)*<w:ignoreElements\s.*\/>/ ? $_ : () ;
        }, @in;
        my $e = join "\x0a\t", "wordDocument end", pop @w;
        my $s = join "\x0a\t", "wordDocument start", @w;
        $s =~ s/(\t)(\t)*/$1/g; $s .= "\\n";
        @wordDocument = ( $s, $e );
    }

# - ブロック  body

    sub chk_para { # パラグラフの属性を調べる。 
        my @u = ();
        for( $_[0] =~ /<(?![\/])([^>]+)>/g ) {
            /^\s*([^\s\/]+)\s*/; my ( $t, $p ) = ( $1, $' );
            $p =~ s/\s*\/\s*$//;
            push @u, $p eq '' ? $t : $t." ".$p ;
        }
        my @k = qw(
            b-cs spacing ind jc color
        );
        my $k = '('.( join '|', @k ).')';
        @u = map do { /$k/ ? utf8_to_cp932( $_ ) : () }, @u;
        @u = sort { $a cmp $b } @u;
        my $n = ''; @u = map do { my $p = $n; $n = $_; $p eq $n ? () : $n; }, @u;
        join "\t", @u;
    }

    sub chk_body { # bodyの未知タグ・未知属性を調べる。 
        my @u = ();
        for( @body ) {
            for( /<(?![\/])([^>]+)>/g ) {
                /^\s*([^\s\/]+)\s*/; my ( $t, $p ) = ( $1, $' );
                $p =~ s/\s*\/\s*$//;
                push @u, $p eq '' ? $t : $t."\t".$p ;
            }
        }
        my @k = qw(
            w:body wx:sect w:sectPr w:pStyle w:rPr w:rStyle w:t
            w:tbl w:tblPr w:tr w:trPr w:tc w:tcPr
        );
        my $k = '('.( join '|', @k ).')';
        @u = map do { /^$k(\s|$)/ ? () : utf8_to_cp932( $_ ) }, @u;
        @u = sort { $a cmp $b } @u;
        my $n = ''; @u = map do { my $p = $n; $n = $_; $p eq $n ? () : $n; }, @u;
        @unknown = map do { s/\t/\x0a$&/; $_; }, @u;
    }

# - ブロック  styles

# - ブロック  項目・タグ・属性の削除

    sub pass1 { # ( array )から( del )タグのある項目を省く。 
        my $d = $_[1];
        @{$_[0]} = map do { /<$d[\s>]/ ? () : $_ }, @{$_[0]};
    }

    sub pass2 { # ( array )から( del )タグのない項目を省く。 
        my $d = $_[1];
        @{$_[0]} = map do { /<$d[\s>]/ ? $_ : () }, @{$_[0]};
    }

    sub delTag { # ( array )の各項目で( del )タグを省く。 
        my $d = $_[1];
        for( @{$_[0]} ) { s/\x0a\t*<\/?$d[\s>].*//g; }
    }

    sub delProp { # ( array )の各項目で( tag )タグの( del )属性を省く。 
        my $t = $_[1]; my $d = $_[2];
        for( @{$_[0]} ) {
            s/(<$t)(\s)/$1~$2/g;
            while( /(<$t)~(\s[^>]*)/ ) {
                my $p = $`.$1; my$q = $2; my $r = $';
                $q =~ s/\s$d\s*=\s*(['"]).*?\1//g;
                $_ = $p.$q.$r;
            }
        }
    }

# - 出力xml

    sub ins_parts { # 出力xmlにブロック( block )を挿入する。 
        for( @{$_[0]} ) {
            /\t/ || next;
            my $v = $'; $v =~ s/(^|\x0a)\t*//g;
            push @out, $v;
        }
    }

    sub putF_xml { # xmlを出力する。 
        my $fn = defined( $_[0] ) && $_[0] =~ /\S/ ? $_[0] : $ARGV[0] ;
        $fn =~ /\.sgm$/i && ( $fn =~ s/\.sgm$/.xml/i );
        putF( $fn, join "\x0a", @out );
    }

    sub putF_Lv { # xmlの第( n )階層までを( fn )に出力する。 
        my @x = map do { /^(\t){0,$_[0]}<(?!\/)/ ? $_ : () }, @in;
        putF( $_[1], join "\x0a", @x, "" );
    }

# - xmlへの変換

    sub path_conv { # ( path )を xmlのタグに置換するテーブル で置換する。 
            my $t = $_[0];
            $t =~ s/<\//</;
            defined( $path2xml{ $t } ) && return $path2xml{ $t };
            while( $t =~ /^<[^>]+>/ ) {
                $t = $';
                defined( $path2xml{ $t } ) && return $path2xml{ $t };
            }
            return undef;
    }

    sub prop_get { # ( tag )の属性を読む。 
        my $t = $_[0];
        $t =~ s/^<\s*//; $t =~ s/\s*>$//;
        my @t =
            $t =~ /([\w-]+\s*=\s*'[^']*'|[\w-]+\s*=\s*"[^"]*"|[\w-]+\s*\s*=\S+)\s*/g;
        my $h = {};
        map do {
            /\s*=\s*/; my ( $k, $v ) = ( $`, $' );
            $v =~ /^('|")(.*)\1$/ && ( $v = $2 );
            $h->{ $k } = $v;
        }, @t;
        $h;
    }

    sub prop_conv { # ( xml )に属性( h )を置換テーブル( p )( pr )で埋め込む。 
        my ( $t, $h, $p, $pr, ) = @_;
        $t =~ s/\$nul//g;
        while( $t =~ /〓(?![^@]*(?:〓|$))([^@]*)[@]([@]?[\w-]+)(.*?)(〓|$)/ ) {
            my ( $s, $cs, $k, $cr, $r ) = ( $`, $1, $2, $3, $' );
            $k =~ /^[@]/ && ( $h->{ $k } = $pr->{ $' } );
            my $c = prop_alt( $k, $h, $p );
            $c eq "" || ( $c = "$cs$c$cr" );
            $t = "$s$c$r";
        }
        $t;
    }

    sub prop_alt { # 属性( prop )を置換テーブル( p )で置換する。 
        my ( $k, $h, $p, ) = @_;
        defined( $p->{ $k } ) || return "";
        my @a = @{$p->{ $k }}; my $u = "";
        @a = map do { /^=>/ && ( $u = $' ); /^=>/ ? () : $_; }, @a;
        my $r = $h->{ $k }; defined( $r ) || return $u;
        for( @a ) {
            /=>/; my ( $f, $v ) = ( $`, $' );
            $r =~ /^$f$/i || next;
            my @v = ( $&, $1, $2, $3, $4, $5, $6, $7, $8, $9 );
            $v =~ s/\$&/$v[ 0 ]/g; for( 1 .. 9 ) { $v =~ s/\$$_/$v[ $_ ]/g; }
            $v =~ s/cat\(\s*(\S+)\s*\)/@{$cat{ $1 }}[0]/g;
            $v =~ s/country\(\s*(\S+)\s*\)/@{$country{ $1 }}[0]/g;
            $v =~ s/\@([\w-]+)(?=\s|$)/$h->{ $1 }/g;
            my @t = ();
            my $sn = $k eq '...' ? @{$p->{ 'variablelabel.style' }}[0] :
                                   @{$p->{ $k.'.style' }}[0];
            while( $v =~ /para\(\s*-style：(.*?)-\s*(.*\S)\s*\)/ ) {
                push @t, [ $`, $sn ]; push @t, [ $2, $1 ]; $v = $';
            }
            push @t, [ $v, $sn ];
            $v = join '', map do {
                my $r = "";
                @$_[0] ne "" && @$_[1] ne "" && join '', (
                    '<w:p>', pStyle( @$_[1], $p ),
                    '<w:r>', rStyle( '' ), '<w:t>', @$_[0], '</w:t>', '</w:r>',
                    '</w:p>',
                );
            }, @t;
            return $v;
        }
        return $u;
    }

# - xmlへの変換  属性を調べる

    sub pStyle { # 段落属性( sn )( p )を調べる。 
        my ( $sn, $p, ) = @_; defined( $p ) || ( $p = '' );
        $sn = pStyle_sel( $sn, $p );
        defined( $styleId{ $sn } ) && $styleId{ $sn } ne "" || return "";
        join '', (
            '<w:pPr>', '<w:pStyle w:val="'.$styleId{ $sn }.'"/>',
            ( $p =~ /-(right|center)-/ || $p =~ /[<\s]align="(right|center)"/ ?
                      '<w:jc w:val="'.$1.'"/>' : () ),
            '</w:pPr>'
        );
    }

    sub pStyle_sel { # 段落属性( sn )を( p )で選ぶ。 
        my ( $sn, $p, ) = @_;
        if( $sn =~ /\@variablelabel＝/ ) {
            my $v = ( $p =~ /[<\s]variablelabel(?:-off)?="([^"]*)"/ ) ? $1 : '' ;
            $v = quotemeta_ja( $v );
            $sn =~ s/\@variablelabel＝$v？(.*?)：/$1/;
            $sn =~ s/\@variablelabel＝.*?？.*?：//g;
        }
        $sn;
    }

    sub rStyle { # 文字属性( tags )を調べる。 
        my ( $tags, ) = @_;
        join '', (
            '<w:rPr>', '<w:rFonts w:cs="Arial" w:hint="fareast"/>',
            '<wx:font wx:val="ＭＳ ゴシック"/>',
            ( map do { $tags =~ /<$_>/ ? $atr_tag{ $_ } : () }, keys %atr_tag ),
            ( rColor() ),
            '</w:rPr>',
        );
    }

    sub rColor { # 色属性を調べる。 
        my $c = "";
        for( @pare ) { defined( $_->{ 'color' } ) && ( $c = $_->{ 'color' }, last ); }
        $c = ( $c eq "" ) ? undef : $cols{ $c } ;
        defined( $c ) ? '<w:color w:val="'.$c.'"/>' : '' ;
    }

    sub rLevel { # ( tags )のレベルを調べる。 
        my ( $tags, ) = @_;
        my @l = map do { $tag2num{ '<low'.$_.'subitem>' } }, 1 .. 5;
        my $l = '<('.( join '|', @l ).')>';
        my $lv = 1;
        $tags =~ /^.*$l/ && $tag[ $1 - 1 ] =~ /<low(\d)subitem>/ && ( $lv = $1 );
        my $s = ( $lv == 4 ) ? 'a' : $lv == 5 ? 'i' : 1 ;
        ( $lv, $s );
    }

    sub ListStyle { # 順序番号の文字属性( tags )を調べる。 
        my ( $tags, ) = @_;
        my $wt = '<'.$tag2num{ "<warning>" }.'>';
        join '', (
            '<w:rPr>', '<w:rFonts w:cs="Arial" w:hint="fareast"/>',
            '<wx:font wx:val="ＭＳ ゴシック"/>',
            ( $tags =~ /$wt/ ? '<w:color w:val="FF0000"/>' : '' ),
            '</w:rPr>',
        );
    }

    sub rList { # 順序番号を調べる( tags )( prop )。 
        my ( $tags, $prop, ) = @_;
        my $sn = $prop->{ 'serialno' }; defined( $sn ) && $sn ne '' || return "";
        my $it = '<'.$tag2num{ "<item>" }.'>';
        my $ln = ( $tags =~ /$it$/ ) ? 'ln1' : 'ln2' ;
        my ( $lv, $lv_s ) = rLevel( $tags );
        my $l = "LISTNUM \"$ln\" \\l $lv".( $sn == $lv_s ? " \\s 1" : "" );
        my $rs = ListStyle( $tags );
        join '', (
            '<w:r>', $rs, '<w:fldChar w:fldCharType="begin"/>', '</w:r>',
            '<w:r>', $rs, '<w:instrText> </w:instrText>', '</w:r>',
            '<w:r>', $rs, '<w:instrText>', $l, '</w:instrText>', '</w:r>',
            '<w:r>', $rs, '<w:instrText> </w:instrText>', '</w:r>',
            '<w:r>', $rs, '<w:fldChar w:fldCharType="end"/>',
            '<wx:t wx:val="', $sn, '"/>', '</w:r>',
        );
    }

# - xmlへの変換  冒頭の情報

    sub getF_top { # 冒頭の情報を( fn )から読む。 
        -f $_[0] || err( '  冒頭の情報のファイルがありません： '.$_[0] );
        @top = map do { s/\x0d?\x0a$//; /\S/ ? $_ : () ; }, getF( $_[0] );
    }

# - xmlへの変換  表組

    sub chk_rowspan { # 前の行のrowspanを調べる( p )。 
        my $tc = $tag2num{ "<simptblcell>" };
        my $rs = ( $p =~ /[<\s]rspan="0*(\d+)"/ ) ? $1 : 1 ;
        my $cs = ( $p =~ /[<\s]cspan="0*(\d+)"/ ) ? $1 : 1 ;
        push @span_n, [ $rs, $cs ];
        my $r = '';
        while( $cs ) {
            $cs--;
            while( @span_p ) {
                my $sp = shift @span_p; $$sp[0] || last;
                $r .= join '', (
                    '<w:tc>', '<w:tcPr>', '<w:tcW w:w="'.$w_w.'" w:type="dxa"/>',
                    '<w:shd w:val="clear" w:color="auto" w:fill="auto"/>',
                    ( 1 < $$sp[1] ? '<w:gridSpan w:val="'.$$sp[1].'"/>' : () ),
                    '<w:vmerge/>', '</w:tcPr>',
                    '<w:p>', pStyle( '表内＿項目' ), '</w:p>', '</w:tc>',
                );
            }
        }
        $r;
    }

# - xmlへの変換  強制改行・画像

    sub getS { # 画像( fn )の幅・高さを調べる。 
        my $fn = $_[0];
        my $width = 230; my @s = ( $width, $width );
        my $buf = ''; my $d = '[\x00-\xff]';
        -f $fol.$fn && open( IN, '<'.$fol.$fn ) && read( IN, $buf, 10 ) == 10 ||
            ( msg( '  画像ファイルを読めません（ '.$fn.' ）。' ), return @s );
        $fn =~ /\.gif$/i && $buf =~ /^GIF...($d$d)($d$d)/ &&
            ( $s[0] = unpack( 'v', $1 ), $s[1] = unpack( 'v', $2 ) );
        my $pos = 2; my $ok = 1; my @w = ();
        $fn =~ /\.jpg$/i && $buf =~ /^\xff\xd8\xff(\xe0)($d$d)JFIF/ && do {
            while( $1 ne "\xc0" && $1 ne "\xc0" ) {
                $pos += 2 + unpack( 'n', $2 );
                seek( IN, $pos, 0 ); read( IN, $buf, 9 ) == 9 || ( $ok = 0, last );
                $buf =~ /^\xff($d)($d$d)$d($d$d)($d$d)/; @w = ( $4, $3 );
            }
            $ok && ( @s = map do { unpack( 'n', $_ ) }, @w );
        };
        close( IN );
        my $sc = 0.6; @s = map do { $_ * $sc }, @s;
        my $k = 1; for( @s ) { $_ / $width > $k && ( $k = $_ / $width ) }
        $k > 1 && ( @s = map do { int( $_ / $k + 0.5 ) }, @s );
        @s;
    }

# - 変換規則

    sub getF_s2w { # 変換規則を( fn )から読む。 
        -f $_[0] || err( '  変換規則のファイルがありません： '.$_[0] );
        @s2w = map do { s/\x0d?\x0a$//; /\S/ ? $_ : () ; }, getF( $_[0] );
    }

    sub putF_tag2num { # タグをタグ番号に置換するテーブルを( fn )に出力する。 
        my @t = map do { "$tag2num{ $_ }：$_" }, sort keys %tag2num;
        putF( $_[0], join "\x0a", @t, "" );
    }

# - 変換規則    path2xml

    sub putF_path2xml { # xmlのタグに置換するテーブルを( fn )に出力する。 
        sub sort_path {
            my $sa = $a; $sa =~ s/<\/(\d*)>/<$1>\//g;
            my $sb = $b; $sa =~ s/<\/(\d*)>/<$1>\//g;
            $sa cmp $sb;
        }
        my @k = sort sort_path keys %path2xml;
        @k = map do {
            "$_：\x0a".( join "", map do { "\t$_\x0a" }, @{$path2xml{ $_ }} );
        }, @k;
        putF( $_[0], join "\x0a", @k, "" );
    }

# - 補助の定型ルーチン

    sub utf8_to_cp932 { # utf8文字列( str )を cp932文字列に変換する 
        encode( "cp932", decode( "utf8", $_[0] ) );
    }

    sub cp932_to_utf8 { # cp932文字列( str )を utf8文字列に変換する 
        encode( "utf8", decode( "cp932", $_[0] ) );
    }

    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 addF { # ファイル( 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" }, @_;
    }

# - 構文

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

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