Perl Script 習作

Perlのブラッシュアップのためにサブルーチン化した習作を投下します。元はInDesignから書き出したxmlテキストをタブ区切りテキストに成形するスクリプトの一部。内容は順不同に出現するフィールド名のタグで挟まれた部分を抽出して並び替えて揃えるというものです。↓こんな感じのタブ区切りテキストを表組に使えるテキストに加工するのに作りました。

↓

ちょっと記述が長いかもしれないので、折りたたんでおきます。
（シンタックスハイライトを使って整形しました。2012/2/19）

sub Sample {
 my $inTxt = shift;
 my $outTxt ;
 my @koumoku ;    #並び順が決まっている時は、予めフィールド名を配列にセットしておく。宣言だけだと出現順に並ぶ。
 my @inArr = split("\n", $inTxt);        #改行で一行毎分解
 foreach my $rec (@inArr) {              #一行毎ループ処理
   if($rec ) {                           #空行無視
     my @strArr = split( "\t", $rec );   #タブで分解
     my @keyArr;       #フィールド名リスト
     my %hash ;        #フィールド名をKeyにしたフィールド値のハッシュリスト
     foreach my $aStr (@strArr) {
       if ( $aStr =~ /<(.+?)>/ ) {
         my $getKey = $1 ;    #フィールド名抽出
         my $machStr1 = '<' . $getKey . '>';
         my $machStr2 = '<\/' . $getKey .'>';
         my $keyNum = @keyArr;
         if ( $keyNum > 0 ){
           my $cnt = 0;
           my %edaban;
           my $edabanStr = $getKey;
           foreach my $mystr ( @keyArr) { $edaban{$mystr} = 1 }
           while ( exists $edaban{$edabanStr} ) {
           $cnt ++;
           $edabanStr = $getKey . '-' . $cnt ;  #同じフィールド名がある場合は枝番をつける
         }
         $getKey = $edabanStr;
       }
       push @keyArr , $getKey ;
       if ( $aStr =~ /$machStr1(.*?)$machStr2/ ){
         my $setVal ;
         if ( $1 ) { $setVal = $1 } else { $setVal = "—" }  #フィールド値が空の場合は『—』を代入してフィールド無しと区別
         $hash{$getKey} = $setVal ;    #フィールド値抽出
       }
     }
   }
   my $koumokuNum = @koumoku;
   if ( $koumokuNum = 0 ){
     foreach my $akey ( @keyArr ) { push  @koumoku , $akey }  #項目名を@koumokuに追加する
   } else {
     my %exist ;
     foreach my $akoumoku ( @koumoku) { $exist{$akoumoku} = 1 }
     foreach my $akey ( @keyArr ) {
       unless ( exists $exist{$akey} ) { push  @koumoku , $akey  }  #@koumokuにない項目追加
     }
   }
   #@koumoku順にフィールド値を並び替える
   my @outRec;
   foreach my $keyStr ( @koumoku ) {
     my $setStr ;
     if( exists $hash{$keyStr} ) {
       $setStr = $hash{$keyStr} ;
     } else {
       $setStr = "" ;
     }
   push @outRec , $setStr ;
   }
   my $outStr = join "\t" , @outRec ;
   $outTxt = $outTxt . $outStr . "\n";
   }
  }
  my $koumokuStr = join "\t" , @koumoku ;
  $outTxt = $koumokuStr . "\n" . $outTxt ;    #１行目に項目名を追加
  return $outTxt;
}

なんか無駄に長くなっているような気もするので、こう書き替えればもっとスマートだよ、なんて突っ込み大歓迎です。