File Coverage

blib/lib/String/ShortHostname.pm
Criterion Covered Total %
statement 23 23 100.0
branch 5 6 83.3
condition n/a
subroutine 6 6 100.0
pod 0 1 0.0
total 34 36 94.4


line stmt bran cond sub pod time code
1 1     1   55430 use strict;
  1         2  
  1         24  
2 1     1   4 use warnings;
  1         2  
  1         29  
3             package String::ShortHostname;
4              
5             # ABSTRACT: extracts the first field from an FQDN
6              
7 1     1   468 use Moose;
  1         388139  
  1         8  
8 1     1   6256 use Moose::Exporter;
  1         2  
  1         5  
9 1     1   73 use 5.10.0;
  1         4  
10              
11              
12             Moose::Exporter->setup_import_methods( as_is => [ 'short_hostname' ]);
13              
14             has 'hostname' => (
15             is => 'rw',
16             isa => 'Str',
17             required => 1,
18             default => '',
19             predicate => 'has_hostname',
20             );
21              
22             around BUILDARGS => sub {
23             my $orig = shift;
24             my $class = shift;
25              
26             if ( @_ == 1 && !ref $_[0] ) {
27             return $class->$orig( hostname => short_hostname($_[0]) );
28             }
29             else {
30             return $class->$orig(@_);
31             }
32             };
33              
34             around 'hostname' => sub {
35             my $orig = shift;
36             my $self = shift;
37              
38             return $self->$orig() unless @_;
39              
40             return $self->$orig( short_hostname( shift ) );
41             };
42              
43             sub short_hostname {
44 4     4 0 587 my $hostname = shift;
45 4         8 my @bits;
46 4 50       16 @bits = split /\./, $hostname if $hostname;
47 4         7 my $alpha_found;
48 4         6 for( @bits ){
49 13 100       36 $alpha_found = 1 if /\D/;
50             }
51 4 100       10 if( $alpha_found ){
52 3         36 return $bits[0];
53             } else {
54 1         4 return $hostname; # probably an IP Address
55             }
56             }
57              
58              
59              
60             1;
61              
62             __END__
63              
64             =pod
65              
66             =encoding UTF-8
67              
68             =head1 NAME
69              
70             String::ShortHostname - extracts the first field from an FQDN
71              
72             =head1 VERSION
73              
74             version 1.000
75              
76             =head1 SYNOPSIS
77              
78             This module will take a fully qualified domain name and return the first field which is normally the
79             short hostname (mostly equivalent to C<hostname -s> on Linux).
80              
81             use String::ShortHostname;
82             my $fqdn = 'testhost.example.com';
83             my $hostname = short_hostname( $fqdn );
84             print $hostname;
85             # prints 'testhost'
86              
87             If an IPv4 address is passed to it, it will be returned verbatim. Otherwise the logic is simply to
88             return everything before the first C<.>.
89              
90             Alternatively, it can be used in an OO way, but without much benefit:
91              
92             use String::ShortHostname;
93             my $fqdn = 'testhost.example.com';
94             my $short = String::ShortHostname->new( $fqdn );
95             my $hostname = $short->hostname;
96             print $hostname;
97             # prints 'testhost'
98              
99             =head1 BUGS/FEATURES
100              
101             Please report any bugs or feature requests in the issues section of GitHub:
102             L<https://github.com/Q-Technologies/perl-String-ShortHostname>. Ideally, submit a Pull Request.
103              
104             =head1 AUTHOR
105              
106             Matthew Mallard <mqtech@cpan.org>
107              
108             =head1 COPYRIGHT AND LICENSE
109              
110             This software is copyright (c) 2019 by Matthew Mallard.
111              
112             This is free software; you can redistribute it and/or modify it under
113             the same terms as the Perl 5 programming language system itself.
114              
115             =cut