File Coverage

lib/File/URIList.pm

Criterion	Covered	Total	%
statement	26	129	20.1
branch	0	78	0.0
condition	0	23	0.0
subroutine	9	18	50.0
pod	7	7	100.0
total	42	255	16.4

# Copyright (c) 2025 Philipp Schafft

# licensed under Artistic License 2.0 (see LICENSE file)

# ABSTRACT: module for reading and writing RFC 2483 URI lists

package File::URIList;

use v5.20;
use strict;
use warnings;

use Fcntl qw(SEEK_SET);
use URI;
use URI::file;
use Carp;
use parent qw(Data::Identifier::Interface::Userdata Data::Identifier::Interface::Subobjects);

use constant {
    CRLF => "\015\012",
};

our $VERSION = v0.04;

my %_check_defaults = (
    blank_lines => 'die',
    extra_spaces => 'die',
    no_scheme => 'die',
    slash_as_local => undef,
);



#@returns __PACKAGE__
sub new {
    my ($pkg, $handle, %opts) = @_;
    my %check = %_check_defaults;
    my $self = bless {check => \%check}, $pkg;

    foreach my $key (keys %_check_defaults) {
        if (exists $opts{$key}) {
            $check{$key} = delete $opts{$key};
        }
    }

    if (defined(my $baseuri = delete $opts{baseuri})) {
        $baseuri = URI->new($baseuri) unless eval { $baseuri->isa('URI') };
        $self->{baseuri} = $baseuri;
    }

    croak 'Stray options passed' if scalar keys %opts;

    unless (ref $handle) {
        open(my $fh, '<', $handle) or die $!;
        $handle = $fh;
    }

    binmode($handle) or die $!;

    $self->{fh} = $handle;

    return $self;
}


sub write_comment {
    my ($self, @list) = @_;
    my $fh = $self->{fh};

    foreach my $ent (@list) {
        if (ref($ent) eq 'ARRAY') {
            $self->write_comment(@{$ent});
        } elsif (ref($ent)) {
            print $fh '# ';
            $self->write_list($ent);
        } else {
            foreach my $line (split/\015?\012/, $ent) {
                print $fh '# ', $line, CRLF;
            }
        }
    }
}


sub write_list {
    my ($self, @list) = @_;
    my $fh = $self->{fh};

    foreach my $ent (@list) {
        if (ref($ent) eq 'ARRAY') {
            $self->write_list(@{$ent});
        } elsif (ref($ent)) {
            if ($ent->isa('URI')) {
                print $fh $ent->as_string, CRLF;
            } elsif ($ent->isa('Data::Identifier')) {
                print $fh $ent->uri, CRLF;
            } elsif ($ent->isa('Data::URIID::Result')) {
                print $fh $ent->url, CRLF;
            } elsif ($ent->isa('Data::URIID::Base') || $ent->isa('Data::Identifier::Interface::Simple')) {
                print $fh $ent->as('uri'), CRLF;
            } elsif ($ent->isa('Data::Identifier::Cloudlet')) {
                $self->write_list($ent->roots);
            } elsif ($ent->isa(__PACKAGE__)) {
                $ent->read_to(sub {
                        print $fh $_[1]->as_string, CRLF;
                    });
            } else {
                croak 'Unsupported object passed';
            }
        } else {
            print $fh URI->new($ent)->as_string, CRLF;
        }
    }
}


sub read_to {
    my ($self, $cb, %opts) = @_;
    my $fh = $self->{fh};
    my $as = delete($opts{as}) // 'URI';

    croak 'Stray options passed' if scalar keys %opts;

    # Preload modules as needed:
    if ($as ne 'URI') {
        require Data::Identifier;
    }

    if (ref($cb) eq 'ARRAY') {
        my $list = $cb;
        $cb = sub { push(@{$list}, $_[1]) };
    }

    while (defined(my $line = <$fh>)) {
        $line =~ s/\015?\012$//;

        next if $line =~ /^#/;

        if ($line =~ /^\s/ || $line =~ /\s$/) {
            my $action = $self->{check}{extra_spaces} // '';

            if ($action eq 'die') {
                croak 'Input line with extra spaces, aborting';
            } elsif ($action eq 'trim') {
                $line =~ s/^\s+//;
                $line =~ s/\s+$//;
            } elsif ($action eq 'pass') {
                # no-op
            } else {
                croak 'Input line with extra spaces and bad handling action selected: '.$action;
            }
        }

        if ($line eq '') {
            my $action = $self->{check}{blank_lines} // '';

            if ($action eq 'die') {
                croak 'Blank line in input, aborting';
            } elsif ($action eq 'skip') {
                next;
            } elsif ($action eq 'undef') {
                $cb->($self, undef);
                next;
            } elsif ($action eq 'pass') {
                # no-op
            } else {
                croak 'Blank line in input and bad handling action selected: '.$action;
            }
        }

        if ($line =~ /^\// && $self->{check}{slash_as_local}) {
            $line = URI::file->new($line);
        }

        if (!ref($line) && !defined($self->{baseuri}) && $line !~ /^[a-zA-Z][a-zA-Z0-9\+\.\-]+:/) {
            my $action = $self->{check}{no_scheme} // '';

            if ($action eq 'die') {
                croak 'URI with no scheme, aborting';
            } elsif ($action eq 'pass') {
                # no-op
            } else {
                croak 'URI with no scheme and bad handling action selected: '.$action;
            }
        }

        unless (ref $line) {
            if (defined $self->{baseuri}) {
                $line = URI->new_abs($line, $self->{baseuri});
            } else {
                $line = URI->new($line);
            }
        }

        if ($as ne 'URI') {
            $line = $line->Data::Identifier::as($as);
        }

        $cb->($self, $line);
    }
}


sub read_as_list {
    my ($self, %opts) = @_;
    my $list = [];
    my $listas = delete $opts{listas};

    delete $opts{list}; # we are always in list mode

    $self->read_to($list, %opts);

    if (defined($listas)) {
        require Data::Identifier::Cloudlet;
        $list = Data::Identifier::Cloudlet->new(root => $list)->as($listas);
    }

    return $list;
}


sub rewind {
    my ($self) = @_;
    my $fh = $self->{fh};

    $fh->seek(0, SEEK_SET) or die $!;
    $fh->input_line_number(1);
}


sub clear {
    my ($self) = @_;
    my $fh = $self->{fh};

    $self->rewind;

    $fh->truncate(0);
}

1;

__END__