view release on metacpan or  search on metacpan

Lite/XHF.pm  view on Meta::CPAN

sub configure_filename_for_error {
  (my MY $self, my ($fn)) = @_;
  $self->{cf_filename} = $fn;
}

# To accept in-stream encoding spec.
# (See YATT::Lite::Test::XHFTest::load and t/lite_xhf.t)
sub configure_encoding {
  (my MY $self, my $value) = @_;
  $self->{fh_configured} = 0;
  $self->{cf_encoding} = $value;
}

sub configure_binary {
  (my MY $self, my $value) = @_;
  warnings::warnif(deprecated =>
		   "XHF option 'binary' is deprecated, use 'bytes' instead");
  $self->{cf_bytes} = $value;
}

sub configure_string {
  my MY $self = shift;
  ($self->{cf_string}) = @_;
  open $self->{cf_FH}, '<', \ $self->{cf_string}
    or croak "Can't create string stream: $!";
  $self;
}

sub trace {
  (my MY $reader, my ($msg, @desc)) = @_;
  print STDERR "  " x $reader->{_depth}, $msg, terse_dump(@desc), "\n";
}

sub read_all {
  (my MY $self) = @_;
  my @res;
  while (my @block = $self->read) {
    push @res, @block;
  }
  wantarray ? @res : do {
    my %dict = @res;
    \%dict;
  };
}

# XXX: Should I rename this to read_one()?
sub read {
  my MY $self = shift;
  $self->cf_let(\@_, sub {
		  if (my @tokens = $self->tokenize) {
		    $self->organize(@tokens);
		  } else {
		    return;
		  }
		});
}

sub tokenize {
  (my MY $self) = @_;
  local $/ = "";
  my $fh = $$self{cf_FH};
  unless ($self->{fh_configured}++) {
    if (not $self->{cf_bytes} and not $self->{cf_string}
	and $self->{cf_encoding}) {
      binmode $fh, ":encoding($self->{cf_encoding})";
    }
    if ($self->{cf_crlf}) {
      binmode $fh, ":crlf";
    }
  }

  my @tokens;
 LOOP: {
    do {
      defined (my $para = <$fh>) or last LOOP;
      $para = untaint_unless_tainted
	($self->{cf_filename} // $self->{cf_string}
	 , $para);
      @tokens = $self->tokenize_1($para);
    } until (not $self->{cf_skip_comment} or @tokens);
  }
  @tokens;
}

sub tokenize_1 {
  my MY $reader = shift;
  $_[0] =~ s{\n+$}{\n}s;
  $_[0] =~ s{\r+}{}g if $reader->{cf_nocr};
  if (my $sub = $reader->{cf_subst}) {
    local $_;
    *_ =  \ $_[0];
    $sub->($_);
  }
  my $lineno = $reader->{cf_first_lineno} // 1;
  my ($pos, $ncomments, @tokens, @result);
  foreach my $token (@tokens = split /(?<=\n)(?=[^\ \t])/, $_[0]) {
    $pos++;
    if ($token =~ s{^(?:\#[^\n]*(?:\n|$))+}{}) {
      $ncomments++;
      next if $token eq '';
    }

    unless ($token =~ s{^($cc_name*$re_suffix*) ($cc_sigil) (?:($cc_tabsp)|(\n|$))}{}x) {
      croak "Invalid XHF token '$token' ".$reader->fileinfo_lineno($lineno)."\n";
    }
    my ($name, $sigil, $tabsp, $eol) = ($1, $2, $3, $4);

    if ($name eq '') {
      croak "Invalid XHF token(name is empty for '$token') "
        .$reader->fileinfo_lineno($lineno)."\n"
	if $sigil eq ':' and not $reader->{cf_allow_empty_name};
    } elsif ($NAME_LESS{$sigil}) {
      croak "Invalid XHF token('$sigil' should not be prefixed by name '$name') "
        .$reader->fileinfo_lineno($lineno)."\n";
    }

    # Comment fields are ignored.
    $ncomments++, next if $sigil eq "#";

    if ($CLO{$sigil}) {