| File: | lib/CheckSpelling/Util.pm |
| Coverage: | 97.5% |
| line | stmt | bran | cond | sub | time | code |
|---|---|---|---|---|---|---|
| 1 | #! -*-perl-*- | |||||
| 2 | ||||||
| 3 | 13 13 | 136871 14 | use v5.20; | |||
| 4 | 13 13 13 | 15 13 32 | use utf8; | |||
| 5 | 13 13 13 | 152 6 719 | use feature 'unicode_strings'; | |||
| 6 | ||||||
| 7 | package CheckSpelling::Util; | |||||
| 8 | ||||||
| 9 | 13 13 13 | 186 3909 397 | use Encode qw/decode_utf8 encode_utf8 FB_DEFAULT/; | |||
| 10 | 13 13 13 | 1507 21174 373 | use HTTP::Date; | |||
| 11 | 13 13 13 | 34 7 243 | use feature 'signatures'; | |||
| 12 | 13 13 13 | 17 5 9837 | no warnings qw(experimental::signatures); | |||
| 13 | ||||||
| 14 | our $VERSION='0.1.0'; | |||||
| 15 | ||||||
| 16 | sub get_file_from_env { | |||||
| 17 | 428 | 261 | my ($var, $fallback) = @_; | |||
| 18 | 428 | 523 | return $fallback unless defined $ENV{$var}; | |||
| 19 | 145 | 120 | $ENV{$var} =~ /(.*)/s; | |||
| 20 | 145 | 116 | return $fallback if $1 eq ''; | |||
| 21 | 144 | 281 | return $1; | |||
| 22 | } | |||||
| 23 | ||||||
| 24 | sub get_file_from_env_utf8 { | |||||
| 25 | 90 | 55 | return decode_utf8(get_file_from_env(@_)); | |||
| 26 | } | |||||
| 27 | ||||||
| 28 | sub get_val_from_env { | |||||
| 29 | 107 | 271 | my ($var, $fallback) = @_; | |||
| 30 | 107 | 112 | return $fallback unless defined $ENV{$var}; | |||
| 31 | 52 | 99 | $ENV{$var} =~ /^(\d+)$/; | |||
| 32 | 52 | 104 | return $1 || $fallback; | |||
| 33 | } | |||||
| 34 | ||||||
| 35 | 134 134 134 134 | 90 50 51 57 | sub case_biased :prototype($$) ($a, $b) { | |||
| 36 | 134 | 184 | lc($a) cmp lc($b) || $a cmp $b; | |||
| 37 | } | |||||
| 38 | ||||||
| 39 | 67 67 67 67 | 33 26 33 22 | sub number_biased :prototype($$) ($a, $b) { | |||
| 40 | 67 | 47 | my ($aUnchecked, $bUnchecked) = ($a, $b); | |||
| 41 | 67 | 93 | while ($aUnchecked ne '' && $bUnchecked ne '') { | |||
| 42 | 93 | 44 | my ($aNumber, $bNumber); | |||
| 43 | 93 | 69 | if ($aUnchecked =~ m/^(\d+)(.*)/) { | |||
| 44 | 25 | 14 | $aNumber = $1; | |||
| 45 | 25 | 14 | $aUnchecked = $2; | |||
| 46 | } | |||||
| 47 | 93 | 73 | if ($bUnchecked =~ m/^(\d+)(.*)/) { | |||
| 48 | 25 | 6 | $bNumber = $1; | |||
| 49 | 25 | 19 | $bUnchecked = $2; | |||
| 50 | } | |||||
| 51 | 93 | 79 | if (defined $aNumber && defined $bNumber) { | |||
| 52 | 22 | 36 | return $aNumber <=> $bNumber if ($aNumber != $bNumber); | |||
| 53 | } else { | |||||
| 54 | 71 | 46 | return $aNumber cmp $bUnchecked if defined $aNumber; | |||
| 55 | 68 | 34 | return $aUnchecked cmp $bNumber if defined $bNumber; | |||
| 56 | 65 | 25 | my ($aLetters, $bLetters); | |||
| 57 | 65 | 44 | $aUnchecked =~ m/^(\D+)(.*)/; | |||
| 58 | 65 | 31 | $aLetters = $1; | |||
| 59 | 65 | 31 | $aUnchecked = $2; | |||
| 60 | ||||||
| 61 | 65 | 46 | $bUnchecked =~ m/^(\D+)(.*)/; | |||
| 62 | 65 | 30 | $bLetters = $1; | |||
| 63 | 65 | 27 | $bUnchecked = $2; | |||
| 64 | ||||||
| 65 | 65 | 154 | return case_biased($aLetters, $bLetters) if (defined $aLetters && defined $bLetters && !($aLetters eq $bLetters)); | |||
| 66 | } | |||||
| 67 | } | |||||
| 68 | 4 | 4 | return $aUnchecked cmp $bUnchecked; | |||
| 69 | } | |||||
| 70 | ||||||
| 71 | sub list_with_terminator { | |||||
| 72 | 8 | 723 | my ($terminator, @list) = @_; | |||
| 73 | 8 66 | 7 59 | return join "", map { "$_$terminator" } @list; | |||
| 74 | } | |||||
| 75 | ||||||
| 76 | sub read_file { | |||||
| 77 | 4 | 762 | my ($name) = @_; | |||
| 78 | 4 | 9 | local $/ = undef; | |||
| 79 | 4 | 2 | my ($text, $file); | |||
| 80 | 4 | 44 | if (open $file, '<:utf8', $name) { | |||
| 81 | 3 | 54 | $text = <$file>; | |||
| 82 | 3 | 10 | close $file; | |||
| 83 | } else { | |||||
| 84 | 1 | 18 | print STDERR "Could not open file ($name)\n"; | |||
| 85 | } | |||||
| 86 | 4 | 12 | return $text; | |||
| 87 | } | |||||
| 88 | ||||||
| 89 | sub maybe_str2time { | |||||
| 90 | 10 | 11 | my ($time) = @_; | |||
| 91 | 10 | 6 | $time = str2time $time; | |||
| 92 | 10 | 141 | return $time if $time; | |||
| 93 | } | |||||
| 94 | ||||||
| 95 | sub print_insert { | |||||
| 96 | 2 | 6 | open INSERT, "<", $ENV{insert}; | |||
| 97 | 2 | 4 | local $/=undef; | |||
| 98 | 2 | 11 | print <INSERT>; | |||
| 99 | 2 | 4 | print "\n"; | |||
| 100 | 2 | 4 | close INSERT; | |||
| 101 | } | |||||
| 102 | ||||||
| 103 | sub insert_into_summary { | |||||
| 104 | 2 | 1955 | my $state=0; | |||
| 105 | 2 | 8 | open BASE, "<", $ENV{base}; | |||
| 106 | 2 | 11 | while (<BASE>){ | |||
| 107 | 20 | 19 | if ($state==0) { | |||
| 108 | 2 | 5 | $state = 1 if /^(?:#+ |<details><summary>)Unrecognized words/; | |||
| 109 | } elsif ($state==1) { | |||||
| 110 | 5 | 7 | if (/<details><summary>These words/) { | |||
| 111 | 1 | 1 | $state=2; | |||
| 112 | } elsif (m{<details><summary>To accept }) { | |||||
| 113 | 1 | 1 | $state=3; | |||
| 114 | 1 | 1 | print_insert(); | |||
| 115 | 1 | 1 | print "**OR**\n\n\n"; | |||
| 116 | } elsif (m{^<details><summary>}) { | |||||
| 117 | 1 | 1 | $state=3; | |||
| 118 | 1 | 3 | print_insert(); | |||
| 119 | } | |||||
| 120 | } elsif ($state==2) { | |||||
| 121 | 3 | 3 | $state=1 if m{^</details><p></p>}; | |||
| 122 | } | |||||
| 123 | 20 | 45 | print; | |||
| 124 | } | |||||
| 125 | 2 | 10 | close BASE; | |||
| 126 | } | |||||
| 127 | ||||||
| 128 | sub calculate_delay { | |||||
| 129 | 11 | 829 | my (@lines) = @_; | |||
| 130 | 11 | 7 | my $now_stamp = time; | |||
| 131 | 11 | 5 | my ($requested, $expires, $delay); | |||
| 132 | 11 | 7 | for my $line (@lines) { | |||
| 133 | 15 | 15 | if ($line =~ /^date:\s*(.*)/i) { | |||
| 134 | 5 | 3 | $requested = maybe_str2time($1); | |||
| 135 | 5 | 5 | next; | |||
| 136 | } | |||||
| 137 | 10 | 12 | if ($line =~ /^expires:\s*(.*)/i) { | |||
| 138 | 5 | 2 | $expires = maybe_str2time($1); | |||
| 139 | 5 | 4 | next; | |||
| 140 | } | |||||
| 141 | 5 | 9 | next unless $line =~ /^retry-after:\s*(\d+)/i; | |||
| 142 | 4 | 6 | $delay = $1 || 1; | |||
| 143 | } | |||||
| 144 | 11 | 9 | return $delay if defined $delay; | |||
| 145 | 8 | 12 | if (defined $requested && defined $expires) { | |||
| 146 | 2 | 1 | $delay = $expires - $requested; | |||
| 147 | } | |||||
| 148 | 8 | 7 | $delay = 5 unless defined $delay && $delay > 0; | |||
| 149 | ||||||
| 150 | 8 | 14 | return $delay; | |||
| 151 | } | |||||
| 152 | ||||||
| 153 | sub truncate_with_ellipsis { | |||||
| 154 | 8 | 7 | my ($text, $length) = @_; | |||
| 155 | 8 | 67 | $text =~ s/^(.{$length}).{4,}?(\s?`+|)$/$1$2â¦/; | |||
| 156 | 8 | 11 | return $text; | |||
| 157 | } | |||||
| 158 | ||||||
| 159 | sub wrap_in_backticks { | |||||
| 160 | 1351 | 891 | my ($a) = @_; | |||
| 161 | 1351 | 576 | my $longest = 0; | |||
| 162 | 1351 | 865 | while ($a =~ /(`+)/g) { | |||
| 163 | 7 | 5 | my $length = length $1; | |||
| 164 | 7 | 8 | $longest = $length if $length > $longest; | |||
| 165 | } | |||||
| 166 | 1351 | 649 | my $q = '`'x ($longest + 1); | |||
| 167 | 1351 | 1182 | $a = " $a " if ($a =~ m<^`|`$>); | |||
| 168 | 1351 | 1129 | return "$q$a$q"; | |||
| 169 | } | |||||
| 170 | ||||||
| 171 | sub tear_here { | |||||
| 172 | 7 | 21 | my ($exit) = @_; | |||
| 173 | 7 | 5 | our $exited; | |||
| 174 | 7 | 11 | return if defined $exited; | |||
| 175 | 7 | 63 | print STDERR "\n<<<TEAR HERE<<<exit: $exit\n"; | |||
| 176 | 7 | 22 | print STDOUT "\n<<<TEAR HERE<<<exit: $exit\n"; | |||
| 177 | 7 | 16 | $exited = $exit; | |||
| 178 | } | |||||
| 179 | sub die_custom { | |||||
| 180 | 3 | 8 | my ($program, $line, $message) = @_; | |||
| 181 | 3 | 37 | print STDERR "$message at $program line $line.\n"; | |||
| 182 | 3 | 5 | tear_here(1); | |||
| 183 | 3 | 24 | die "stopping"; | |||
| 184 | } | |||||
| 185 | ||||||
| 186 | 1; | |||||