File Coverage

blib/lib/Convos/Core/Util.pm
Criterion Covered Total %
statement 49 59 83.0
branch 5 10 50.0
condition 0 3 0.0
subroutine 12 13 92.3
pod 5 5 100.0
total 71 90 78.8


line stmt bran cond sub pod time code
1             package Convos::Core::Util;
2              
3             =head1 NAME
4              
5             Convos::Core::Util - Utility functions for Convos
6              
7             =head1 SYNOPSIS
8              
9             L can export any of the L.
10              
11             =cut
12              
13 37     37   16300 use Mojo::Base 'Exporter';
  37         7744  
  37         212  
14              
15 37     37   5969 no warnings "utf8";
  37         59  
  37         1137  
16 37     37   713 use Mojo::Log;
  37         46924  
  37         280  
17 37     37   1423 use Mojo::UserAgent;
  37         197609  
  37         239  
18 37     37   1789 use Parse::IRC ();
  37         3754  
  37         582  
19 37     37   877 use Unicode::UTF8 'decode_utf8';
  37         1040  
  37         1874  
20 37     37   19297 use Time::Piece;
  37         232064  
  37         156  
21              
22             our $SERVER_NAME_RE = qr{(?:\w+\.[^:/]+|localhost|loopback):?\d*};
23              
24             our @EXPORT_OK = qw( as_id format_time id_as logf pretty_server_name $SERVER_NAME_RE );
25              
26             =head1 FUNCTIONS
27              
28             =head2 as_id
29              
30             $id = as_id @str;
31              
32             This method will convert the input to a string which can be used as id
33             attribute in your HTML doc.
34              
35             It will convert non-word characters to ":hex" and join C<@str> with ":00".
36              
37             =cut
38              
39             sub as_id {
40 8         12 join ':00', map {
41 8         25 local $_ = $_; # local $_ is for changing constants and not changing input
42 8         14 s/:/:3a/g;
43 8         29 s/([^\w:-])/{ sprintf ':%02x', ord $1 }/ge;
  6         7  
  6         36  
44 8         42 $_;
45 4     4 1 1005 } grep { length $_; } @_;
46             }
47              
48             =head2 format_time
49              
50             $str = format_time $timestamp, $format;
51              
52             =cut
53              
54             sub format_time {
55 1     1 1 27 my $date = localtime shift;
56 1         123 my $format = shift;
57              
58 1         8 return decode_utf8($date->strftime($format));
59             }
60              
61             =head2 id_as
62              
63             @str = id_as $id;
64              
65             Reverse of L.
66              
67             =cut
68              
69             sub id_as {
70 7         28 map {
71 3     3 1 16 s/:(\w\w)/{ chr hex $1 }/ge;
  7         8  
  7         35  
72 7         36 $_;
73             } split /:00/, $_[0];
74             }
75              
76             =head2 logf
77              
78             $c->logf($level => $format, @args);
79             $c->logf(debug => 'yay %s', \%data);
80              
81             Used to log more complex datastructures and to prevent logging C.
82              
83             =cut
84              
85             sub logf {
86 37     37   16113 use Data::Dumper;
  37         61  
  37         14943  
87 0     0 1 0 my ($self, $level, $format, @args) = @_;
88 0   0     0 my $log = $self->{app}{log} || $self->{log} || Mojo::Log->new;
89              
90 0         0 local $Data::Dumper::Maxdepth = 2;
91 0         0 local $Data::Dumper::Indent = 0;
92 0         0 local $Data::Dumper::Terse = 1;
93              
94 0         0 for my $arg (@args) {
95 0 0       0 if (ref($arg) =~ /^\w+$/) {
    0          
96 0         0 $arg = Dumper($arg);
97             }
98             elsif (!defined $arg) {
99 0         0 $arg = '__UNDEF__';
100             }
101             }
102              
103 0         0 $log->$level(sprintf $format, @args);
104             }
105              
106             =head2 pretty_server_name
107              
108             $str = pretty_server_name($server);
109              
110             Removes "ssl\.", "irc.", "chat." from the beginning and ".com", ".org", ...
111             from the end. Converts all non word and "_" to "-". Also removes the port.
112              
113             Also has special handling for $servers matching...
114              
115             $server | $str
116             -------------|-------
117             irc.perl.org | magnet
118             efnet | efnet
119              
120             =cut
121              
122             sub pretty_server_name {
123 6     6 1 648 my ($name) = @_;
124              
125 6 50       19 return '' unless defined $name;
126 6 100       44 return 'magnet' if $name =~ /\birc\.perl\.org\b/i; # also match ssl.irc.perl.org
127 3 100       19 return 'efnet' if $name =~ /\befnet\b/i;
128              
129 2         13 $name =~ s!^(irc|chat)\.!!; # remove common prefixes from server name
130 2         8 $name =~ s!:\d+$!!; # remove port
131 2         31 $name =~ s!\.\w{2,3}$!!; # remove .com, .no, ...
132 2         5 $name =~ s![\W_]+!-!g; # make pretty url
133 2         12 $name;
134             }
135              
136             =head1 AUTHOR
137              
138             Jan Henning Thorsen - C
139              
140             =cut
141              
142             1;