view release on metacpan or  search on metacpan

Lite/Test/XHFTest.pm  view on Meta::CPAN

    $self->{global} = $item->{cf_global};
    next;
  }
  push @{$self->{tests}}, $self->fixup_item($item);
  $self->{numtests} += $item->ntests;
}

sub fixup_item {
  (my MY $self, my Item $test) = @_;
  my Item $prev = $self->{prev_item};
  $test->{cf_FILE} ||= do {
    if ($prev && $prev->{cf_FILE} =~ m{%d}) {
      $prev->{cf_FILE}
    } else {
      "f%d.$self->{cf_ext}"
    }
  };

  $test->{realfile} = do {
    if ($test->{cf_IN}) {
      no if $] >= 5.021002, warnings => qw/redundant/;
      sprintf($test->{cf_FILE}, 1+@{$self->{file_list} //= []})
    } else {
      $prev->{realfile}
    }
  };

  $test->{cf_WIDGET} ||= do {
    my $widget = $test->{realfile};
    $widget =~ s{\.\w+$}{};
    $widget =~ s{/}{:}g;
    $widget;
  };

  if ($test->{cf_IN}) {
    if (my $conflict = $self->{file_dict}{$test->{realfile}}) {
      die "FILE name confliction in test $test";
    }
    $self->{file_dict}{$test->{realfile}} = $test;
    push @{$self->{file_list}}, $test->{realfile};
  }

  if ($test->{cf_OUT} || $test->{cf_ERROR}) {
    $test->{cf_WIDGET} ||= $prev && $prev->{cf_WIDGET};
    if (not $test->{cf_TITLE} and $prev) {
      $test->{num} = default($prev->{num}, 0) + 1;
      $test->{cf_TITLE} = $prev->{cf_TITLE};
    }
    $self->{prev_item} = $test;
  }

  $test;
}

sub as_vfs_data {
  my MY $self = shift;
  my (%result);
  # 記述の順番どおりに作成
  foreach my $fn (@{$self->{file_list}}) {
    my Item $item = $self->{file_dict}{$fn};
    my @path = split m|/|, $fn;
    my $path_cursor = path_cursor(\%result, \@path);
    $path[0] =~ s|\.(\w+)$||
      or die "Can't handle filename as vfs key: $fn";
    my $ext = $1;
    if (my $sub = $self->can("convert_$ext")) {
      $sub->($self, $path_cursor, $item)
    } else {
      # XXX: 既に配列になってると困るよね。 rc 系を後回しにすれば大丈夫?
      unless (defined $item->{cf_IN}) {
	die "undef IN"
      }
      $path_cursor->[0]{$path[0]} = $item->{cf_IN};
    }
  }
  \%result;
}

sub path_cursor {
  my ($top, $path) = @_;
  # path を一個残して、vivify する。
  # そこにいたる経路を cursor として返す。
  my $cursor = [$top];
  while (@$path > 1) {
    my $nm = shift @$path;
    $cursor = [$cursor->[0]{$nm} ||= {}, $cursor];
  }
  $cursor;
}

1;