view release on metacpan or  search on metacpan

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

        $self->{link_handler} = $handler;
    }

    if ( defined $param{pre} ) {
        croak "pre option must be a hash reference"
            unless ref($param{pre}) and ref($param{pre}) eq 'HASH';
        $self->{pre} = $param{pre};
    } elsif ( exists $param{pre} ) {
        $self->{pre} = undef;
    }

    $self->{mtime} = $param{mtime};
}


sub _startparsing {
    my $self = shift;

    # we do not init $self->{meta} because it is set in initparams;
    $self->{meta} = { 'FORMAT' => 'BEACON' };
    $self->meta( %{ $self->{pre} } ) if $self->{pre};
    $self->{line} = 0;
    $self->{link} = undef;
    $self->{expanded} = undef;
    $self->{errors} = 0;
    $self->{lasterror} = [];
    $self->{lookaheadline} = undef;
    $self->{fh} = undef;
    $self->{inputlines} = [];
    $self->{examples} = [];

    return unless defined $self->{from};

    # decide where to parse from
    my $type = ref($self->{from});
    if ($type) {
        if ($type eq 'SCALAR') {
            $self->{inputlines} = [ split("\n",${$self->{from}}) ];
        } elsif ($type ne 'CODE') {
            $self->_handle_error( "Unknown input $type" );
            return;
        }
    } elsif( $self->{from} eq '-' ) {
        $self->{fh} = \*STDIN;
    } else {
        if(!(open $self->{fh}, $self->{from})) {
            $self->_handle_error( 'Failed to open ' . $self->{from} );
            return;
        }
    }

    # initlialize TIMESTAMP
    if ($self->{mtime}) {
        my @stat = stat( $self->{from} );
        $self->meta('TIMESTAMP', gmtime( $stat[9] )->datetime() . 'Z' );
    }

    # start parsing
    my $line = $self->_readline();
    return unless defined $line;
    $line =~ s/^\xEF\xBB\xBF//; # UTF-8 BOM (optional)

    do {
        $line =~ s/^\s+|\s*\n?$//g;
        if ($line eq '') {
            $self->{line}++;
        } elsif ($line =~ /^#([^:=\s]+)(\s*[:=]?\s*|\s+)(.*)$/) {
            $self->{line}++;
            eval { $self->meta($1,$3); };
            if ($@) {
                my $msg = $@; $msg =~ s/ at .*$//;
                $self->_handle_error( $msg, $line );
            }
        } else {
            $self->{lookaheadline} = $line;
            return;
        }
        $line = $self->_readline();
    } while (defined $line);
}


sub _handle_error {
    my $self = shift;
    my $msg = shift;
    my $line = shift || $self->{currentline} || '';
    chomp $line;
    $self->{lasterror} = [ $msg, $self->{line}, $line ];
    $self->{errors}++;
    $self->{error_handler}->( $msg, $self->{line}, $line ) if $self->{error_handler};
}

our %ERROR_HANDLERS = (
    'print' => sub {
        my ($msg, $lineno) = @_;
        $msg .= " at line $lineno" if $lineno ;
        print STDERR "$msg\n";
    },
    'warn' => sub {
        my ($msg, $lineno) = @_;
        $msg .= " at line $lineno" if $lineno;
        carp $msg;
    },
    'die' => sub {
        my ($msg, $lineno) = @_;
        $msg .= " at line $lineno" if $lineno;
        croak $msg;
    }
);


sub _readline {
    my $self = shift;
    if ($self->{fh}) {
        return eval { no warnings; readline $self->{fh} };
    } elsif (ref($self->{from}) && ref($self->{from}) eq 'CODE') {
        my $line = eval { $self->{from}->(); };
        if ($@) { # input handler died
            $self->_handle_error( $@, '' );
            $self->{from} = undef;
        }