File Coverage

blib/lib/WWW/Noss/Util.pm
Criterion Covered Total %
statement 38 39 97.4
branch 10 12 83.3
condition 4 7 57.1
subroutine 7 7 100.0
pod 2 2 100.0
total 61 67 91.0


line stmt bran cond sub pod time code
1             package WWW::Noss::Util;
2 3     3   153799 use 5.016;
  3         11  
3 3     3   16 use strict;
  3         23  
  3         95  
4 3     3   15 use warnings;
  3         5  
  3         296  
5             our $VERSION = '2.02';
6              
7 3     3   19 use Exporter qw(import);
  3         6  
  3         175  
8             our @EXPORT_OK = qw(dir resolve_url);
9              
10 3     3   38 use File::Spec;
  3         4  
  3         1865  
11              
12             sub dir {
13              
14 2     2 1 248721 my ($dir, %param) = @_;
15 2   100     11 my $hidden = $param{ hidden } // 0;
16              
17 2 50       147 opendir my $dh, $dir
18             or die "Failed to open $dir as a directory: $!\n";
19 2         67 my @f = sort grep { ! /^\.\.?$/ } readdir $dh;
  12         37  
20 2         46 closedir $dh;
21              
22 2 100       6 unless ($hidden) {
23 1         2 @f = grep { ! /^\./ } @f;
  4         8  
24             }
25              
26 2         4 return map { File::Spec->catfile($dir, $_) } @f;
  7         49  
27              
28             }
29              
30             sub resolve_url {
31              
32 9     9 1 9149 my ($url, $from) = @_;
33              
34 9         78 my ($proto, $root, $path) = $from =~ /^(\w+:\/\/)?([^\/]+)(.*)$/;
35 9   50     25 $proto //= '';
36              
37 9 100       35 if ($url =~ /^\w+:\/\//) {
38 5         25 return $url;
39             }
40              
41 4 50 33     15 if ($proto eq 'shell://' or $proto eq 'file://') {
42 0         0 return undef;
43             }
44              
45 4 100       12 if ($url =~ /^\/\//) {
    100          
46 1         3 $url =~ s/^\/\///;
47 1         4 return $proto . $url;
48             } elsif ($url =~ /^\//) {
49 1         3 return $proto . $root . $url;
50             } else {
51 2         5 $url =~ s/^\.\/+//;
52 2         3 $root =~ s/\/+[^\/]*$//;
53 2         6 return $proto . $root . '/' . $url;
54             }
55              
56             }
57              
58             1;
59              
60             =head1 NAME
61              
62             WWW::Noss::Util - Misc. utility functions for noss
63              
64             =head1 USAGE
65              
66             use WWW::Noss::Util qw(dir resolve_url);
67              
68             my @files = dir('/');
69              
70             my $full_url = resolve_url('/pages', 'https://example.com/home');
71              
72             =head1 DESCRIPTION
73              
74             B is a module that provides various utility functions for
75             L. This is a private module, please consult the L manual for user
76             documentation.
77              
78             =head1 SUBROUTINES
79              
80             Subroutines are not exported automatically.
81              
82             =over 4
83              
84             =item @children = dir($dir, [ %param ])
85              
86             Returns list of children files under directory C<$dir>. C<%param> is an
87             optional hash of additional parameters.
88              
89             The following are valid fields in C<%param>:
90              
91             =over 2
92              
93             =item hidden
94              
95             Boolean determining whether to include hidden files or not. Defaults to false.
96              
97             =back
98              
99             =item $full_url = resolve_url($url, $from)
100              
101             Resolves URL C<$url> found on the page linked by C<$from>. Retuns C if
102             the URL could not be resolved.
103              
104             =back
105              
106             =head1 AUTHOR
107              
108             Written by Samuel Young, Esamyoung12788@gmail.comE.
109              
110             This project's source can be found on its
111             L. Comments and pull
112             requests are welcome!
113              
114             =head1 COPYRIGHT
115              
116             Copyright (C) 2025-2026 Samuel Young
117              
118             This program is free software: you can redistribute it and/or modify
119             it under the terms of the GNU General Public License as published by
120             the Free Software Foundation, either version 3 of the License, or
121             (at your option) any later version.
122              
123             =head1 SEE ALSO
124              
125             L
126              
127             =cut
128              
129             # vim: expandtab shiftwidth=4