view release on metacpan or  search on metacpan

lib/Data/Section.pm  view on Meta::CPAN

#pod
#pod =cut

sub _mk_reader_group {
  my ($mixin, $name, $arg, $col) = @_;
  my $base = $col->{INIT}{into};

  my $default_header_re = qr/
    \A                # start
      _+\[            # __[
        \s*           # any whitespace
          ([^\]]+?)   # this is the actual name of the section
        \s*           # any whitespace
      \]_+            # ]__
      [\x0d\x0a]{1,2} # possible cariage return for windows files
    \z                # end
  /x;

  my $header_re = $arg->{header_re} || $default_header_re;
  $arg->{inherit} = 1 unless exists $arg->{inherit};

  my $default_encoding = defined $arg->{encoding} ? $arg->{encoding} : 'UTF-8';

  my %export;
  my %stash = ();

  $export{local_section_data} = sub {
    my ($self) = @_;

    my $pkg = ref $self ? ref $self : $self;

    return $stash{ $pkg } if $stash{ $pkg };

    my $template = $stash{ $pkg } = { };

    my $dh = do { no strict 'refs'; \*{"$pkg\::DATA"} }; ## no critic Strict
    return $stash{ $pkg } unless defined fileno *$dh;
    binmode( $dh, ":raw :bytes" );

    my ($current, $current_line);
    if ($arg->{default_name}) {
        $current = $arg->{default_name};
        $template->{ $current } = \(my $blank = q{});
    }
    LINE: while (my $line = <$dh>) {
      if ($line =~ $header_re) {
        $current = $1;
        $current_line = 0;
        $template->{ $current } = \(my $blank = q{});
        next LINE;
      }

      last LINE if $line =~ /^__END__/;
      next LINE if !defined $current and $line =~ /^\s*$/;

      Carp::confess("bogus data section: text outside of named section")
        unless defined $current;

      $current_line++;
      unless ($default_encoding eq 'bytes') {
        my $decoded_line = eval { decode($default_encoding, $line, Encode::FB_CROAK) }
          or warn "Invalid character encoding in $current, line $current_line\n";
        $line = $decoded_line if defined $decoded_line;
      }
      $line =~ s/\A\\//;

      ${$template->{$current}} .= $line;
    }

    return $stash{ $pkg };
  };

  $export{local_section_data_names} = sub {
    my ($self) = @_;
    my $method = $export{local_section_data};
    return keys %{ $self->$method };
  };

  $export{merged_section_data} =
    !$arg->{inherit} ? $export{local_section_data} : sub {

    my ($self) = @_;
    my $pkg = ref $self ? ref $self : $self;

    my $lsd = $export{local_section_data};

    my %merged;
    for my $class (@{ mro::get_linear_isa($pkg) }) {
      # in case of c3 + non-$base item showing up
      next unless $class->isa($base);
      my $sec_data = $class->$lsd;

      # checking for truth is okay, since things must be undef or a ref
      # -- rjbs, 2008-06-06
      $merged{ $_ } ||= $sec_data->{$_} for keys %$sec_data;
    }

    return \%merged;
  };

  $export{merged_section_data_names} = sub {
    my ($self) = @_;
    my $method = $export{merged_section_data};
    return keys %{ $self->$method };
  };

  $export{section_data} = sub {
    my ($self, $name) = @_;
    my $pkg = ref $self ? ref $self : $self;

    my $prefix = $arg->{inherit} ? 'merged' : 'local';
    my $method = "$prefix\_section_data";

    my $data = $self->$method;

    return $data->{ $name };
  };

  $export{section_data_names} = sub {
    my ($self) = @_;

    my $prefix = $arg->{inherit} ? 'merged' : 'local';
    my $method = "$prefix\_section_data_names";