File Coverage

blib/lib/Data/iRealPro/Song.pm
Criterion Covered Total %
statement 209 270 77.4
branch 117 176 66.4
condition 18 44 40.9
subroutine 21 22 95.4
pod 0 13 0.0
total 365 525 69.5


line stmt bran cond sub pod time code
1             #! perl
2              
3 21     21   1042 use strict;
  21         42  
  21         576  
4 21     21   99 use warnings;
  21         40  
  21         464  
5 21     21   93 use Carp;
  21         37  
  21         1358  
6              
7             package Data::iRealPro::Song;
8              
9 21     21   10960 use Encode qw( encode_utf8 );
  21         335634  
  21         43057  
10              
11             my %keymap =
12             ( 'C' => 0,
13             'C#' => 1, 'Db' => 1,
14             'D' => 2,
15             'D#' => 3, 'Eb' => 3,
16             'E' => 4,
17             'F' => 5,
18             'F#' => 6, 'Gb' => 6,
19             'G' => 7,
20             'G#' => 8, 'Ab' => 8,
21             'A' => 9,
22             'A#' => 10, 'Bb' => 10,
23             'B' => 11,
24              
25             'A-' => 0,
26             'A#-' => 1, 'Bb-' => 1,
27             'B-' => 2,
28             'C-' => 3,
29             'C#-' => 4, 'Db-' => 4,
30             'D-' => 5,
31             'D#-' => 6, 'Eb-' => 6,
32             'E-' => 7,
33             'F-' => 8,
34             'F#-' => 9, 'Gb-' => 9,
35             'G-' => 10,
36             'G#-' => 11, 'Ab-' => 11,
37             );
38              
39             sub new {
40 23     23 0 193 my ( $pkg, %args ) = @_;
41 23         397 my $self = bless { %args }, $pkg;
42 23   50     226 $self->{transpose} //= 0;
43 23 100       179 $self->parse( $args{data} ) if $args{data};
44 23         130 return $self;
45             }
46              
47             sub parse {
48 14     14 0 83 my ( $self, $data ) = @_;
49              
50             # Split song data into components.
51 14         163 my @a = split( '=', $data );
52 14 50       80 unless ( @a == ( $self->{variant} eq "irealpro" ? 10 : 6 ) ) {
    50          
53 0         0 Carp::croak( "Incorrect ", $self->{variant}, " format 1 " . scalar(@a) );
54             }
55              
56 14         32 my $tokstring;
57              
58 14 50       56 if ( $self->{variant} eq "irealpro" ) {
    0          
59 14         99 $self->{title} = shift(@a);
60 14         95 $self->{composer} = shift(@a);
61 14         51 $self->{a2} = shift(@a); # ??
62 14         54 $self->{style} = shift(@a);
63 14         48 $self->{key} = shift(@a); # C ...
64 14         91 $self->{actual_key} = shift(@a); # '', 0 ...
65 14         171 $self->{raw} = shift(@a);
66 14         45 $self->{actual_style} = shift(@a);
67 14         43 $self->{actual_tempo} = shift(@a);
68 14         38 $self->{actual_repeats} = shift(@a);
69             }
70             elsif ( $self->{variant} eq "irealbook" ) {
71 0         0 $self->{title} = shift(@a);
72 0         0 $self->{composer} = shift(@a);
73 0         0 $self->{style} = shift(@a);
74 0         0 $self->{a3} = shift(@a); # ??
75 0         0 $self->{key} = shift(@a);
76 0         0 $self->{raw} = shift(@a);
77             # Sometimes key and a3 seem swapped.
78 0 0       0 $self->{key} = $self->{a3}, $self->{a3} = "n" if $self->{key} eq "n";
79             }
80 14         35 $tokstring = $self->{raw};
81              
82             # Correct for iReal key transposition.
83 14 100       51 if ( $self->{actual_key} eq '' ) {
84 13         33 $self->{_transpose} = 0;
85             }
86             else {
87 1         8 $self->{_transpose} = ( $self->{actual_key} - $keymap{$self->{key}} ) % 12;
88             }
89              
90             # iRealPro format must start with "1r34LbKcu7" magic.
91 14 50       136 unless ( !!($self->{variant} eq "irealpro")
92             ==
93             !!($tokstring =~ /^1r34LbKcu7/) ) {
94             Carp::croak( "Incorrect ", $self->{variant},
95 0         0 " format 2 " . substr($tokstring,0,20) );
96             }
97              
98             # If iRealPro, deobfuscate. This will also get rid of the magic.
99 14 50       52 if ( $self->{variant} eq "irealpro" ) {
100 14         63 $tokstring = deobfuscate($tokstring);
101 14 50       60 warn( "TOKSTR: >>", $tokstring, "<<\n" ) if $self->{debug};
102             }
103              
104             # FROM HERE we have a pure data string, independent of the
105             # original data format.
106              
107 14         50 $self->{data} = $tokstring;
108 14 50       71 delete $self->{raw} unless $self->{debug};
109              
110 14         48 return $self;
111             }
112              
113             sub tokens {
114 7     7 0 5308 my ( $self ) = @_;
115 7 50       50 $self->tokenize unless $self->{tokens};
116 7         24 return $self->{tokens};
117             }
118              
119             sub cells {
120 1     1 0 920 my ( $self ) = @_;
121 1 50       8 $self->make_cells unless $self->{cells};
122 1         4 return $self->{cells};
123             }
124              
125             ################ Tokenizer ################
126              
127             #### Chord qualities.
128             #
129             # key is the official way to write a chord quality. This is what the iRealPro
130             # editor produces when you specify chords via the menus.
131             # value is the quality as used to select the corresponding image files.
132             #
133             # Often used variants are v for ^, x for # and h for ΓΈ.
134             #
135             # Anything else should be written as a *...* quality.
136              
137             my %chordqual =
138             ( "" => '',
139             "+" => 'p',
140             "-" => 'm',
141             "-#5" => 'mx5',
142             "-11" => 'm11',
143             "-6" => 'm6',
144             "-69" => 'm69',
145             "-7" => 'm7',
146             "-7b5" => 'm7b5',
147             "-9" => 'm9',
148             "-^7" => 'mv7',
149             "-^9" => 'mv9',
150             "-b6" => 'mb6',
151             "11" => '11',
152             "13" => '13',
153             "13#11" => '13x11',
154             "13#9" => '13x9',
155             "13b9" => '13b9',
156             "13sus" => '13sus',
157             "2" => '2',
158             "5" => '5',
159             "6" => '6',
160             "69" => '69',
161             "7" => '7',
162             "7#11" => '7x11',
163             "7#5" => '7x5',
164             "7#9" => '7x9',
165             "7#9#11" => '7x9x11',
166             "7#9#5" => '7x9x5',
167             "7#9b5" => '7x9b5',
168             "7alt" => '7alt',
169             "7b13" => '7b13',
170             "7b13sus" => '7b13sus',
171             "7b5" => '7b5',
172             "7b9" => '7b9',
173             "7b9#11" => '7b9x11',
174             "7b9#5" => '7b9x5',
175             "7b9#9" => '7b9x9',
176             "7b9b13" => '7b9b13',
177             "7b9b5" => '7b9b5',
178             "7b9sus" => '7b9sus',
179             "7sus" => '7sus',
180             "7susadd3" => '7susadd3',
181             "9" => '9',
182             "9#11" => '9x11',
183             "9#5" => '9x5',
184             "9b5" => '9b5',
185             "9sus" => '9sus',
186             "^" => 'v',
187             "^13" => 'v13',
188             "^7" => 'v7',
189             "^7#11" => 'v7x11',
190             "^7#5" => 'v7x5',
191             "^9" => 'v9',
192             "^9#11" => 'v9x11',
193             "add9" => 'add9',
194             "alt" => '7alt',
195             "h" => 'h',
196             "h7" => 'h7',
197             "h9" => 'h9',
198             "o" => 'o',
199             "o7" => 'o7',
200             "sus" => 'sus',
201             );
202              
203             # Build regex.
204             my $p_root = qr{ (?: [ABCDEFG][#b]? | W) }x;
205             # By using reverse the longest alternatives will be tested first.
206             my $p_qual = join("|", map { quotemeta } reverse sort keys %chordqual);
207             $p_qual = qr{ (?: \*[^*]*\* | $p_qual ) }xo;
208             my $p_chord = qr{ $p_root $p_qual (?: / $p_root )? }xo;
209              
210             sub tokenize {
211 8     8 0 899 my ( $self ) = @_;
212 8         20 $_ = $self->{data};
213              
214             # Make tokens.
215 8         16 my @d;
216 8         23 my $l0 = length($_);
217 8         16 my $index = 0;
218              
219             my $d = sub {
220 456   66 456   1764 push( @d, [ $_[0], $_[1] // ${^MATCH}, $index ] );
221             printf STDERR ("%3d %-8s %s\n", $index, $_[1] // ${^MATCH}, $_[0] )
222 456 50 0     1031 if $self->{debug};
223 8         48 };
224              
225             # IMPORTANT: iReal design is visually oriented. All info is added
226             # to the current cell until the pointer advances to the next cell.
227              
228             # Mark markup spaces.
229 8         73 s/([\}\]])( +)([\[\]\{\|])/$1 . ( "\240" x length($2) ) . $3/ge;
  3         59  
230              
231 8         22 my $dataxp = "";
232              
233 8         37 while ( length($_) ) {
234 481         622 my $res;
235 481 100       7860 if ( /^\{/p ) { # |:
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
    100          
    50          
    100          
    100          
    50          
    0          
236 9         46 $d->( "start repeat" );
237             }
238             elsif ( /^\}/p ) { # :|
239 9         19 $d->( "end repeat" );
240             }
241             elsif ( /^\[/p ) { # start section
242 8         23 $d->( "start section" );
243             }
244             elsif ( /^\]/p ) { # end section
245 11         35 $d->( "end section" );
246             }
247             elsif ( /^\*([ABCDvi])/p ) { # section mark
248 9         32 $d->( "mark $1" );
249             }
250             elsif ( /^T(\d)(\d)/p ) { # time signature
251 8         33 $d->( "time " . _timesig( $1, $2) );
252             }
253             elsif ( /^([sl])/p ) { # small/large indicator for chords
254 8 100       26 $d->( $1 eq "s" ? "small" : "large" );
255             }
256             elsif ( /^$p_chord(?:\($p_chord\))?/p ) {
257 178         407 my $t = ${^MATCH};
258 178 50       308 if ( $t =~ /^(.+)Z$/ ) {
259 0         0 $res = $self->xpose($1);
260 0         0 $d->( "chord " . $res );
261 0         0 $d->( "end" );
262 0         0 $res .= "Z";
263             }
264             else {
265 178         353 $res = $self->xpose($t);
266 178         416 $d->( "chord " . $res );
267             }
268             }
269             elsif ( /^$p_root/p ) {
270 0         0 warn( "Unparsable chord: " . ${^MATCH} . "\n" );
271 0         0 $res = $self->xpose(${^MATCH});
272 0         0 $d->( "chord? " . $res );
273             }
274             elsif ( /^\($p_chord\)/p ) {
275 0         0 $res = $self->xpose(${^MATCH});
276 0         0 $d->( "chord " . $res );
277             }
278             elsif ( /^n/p ) { # silent chord
279 0         0 $d->( "chord NC" );
280             }
281             elsif ( /^x/p ) { # repeat the previous measure
282 0         0 $d->( "measure repeat single" );
283             }
284             elsif ( /^r/p ) { # repeat the previous two measures
285 0         0 $d->( "measure repeat double" );
286             }
287             elsif ( /^ +/p ) { # advance to next cell
288 105         336 $d->( "advance " . length(${^MATCH}), " " );
289             }
290             elsif ( /^\|/p ) { # bar
291 87         170 $d->( "bar" );
292             }
293             elsif ( /^N(\d)/p ) {
294 6         25 $d->( "alternative $1" );
295             }
296             elsif ( /^,/p ) { # token separator
297             }
298             elsif ( /^Z/p ) { # end of song or major section
299 3         8 $d->( "end" );
300             }
301             elsif ( /^U/p ) { # end repetition
302 0         0 $d->( "stop" );
303             }
304             elsif ( /^p/p ) {
305 0         0 $d->( "slash repeat" );
306             }
307             elsif ( /^Q/p ) { # 1: jump to coda; 2: coda location
308 3         9 $d->( "coda" );
309             }
310             elsif ( /^f/p ) { # fermata; precedes the chord
311 3         10 $d->( "fermata" );
312             }
313             elsif ( /^S/p ) { # segno
314 3         20 $d->( "segno" );
315             }
316             elsif ( /^Y/p ) { # add vertical space
317 0         0 $d->( "vspace" );
318             }
319             elsif ( /^\240+/p ) { # markup space
320 3         16 $d->( "hspace " . length(${^MATCH}), " " );
321             }
322             elsif ( /^\<(?:\*(\d\d))?(.*?)\>/ps ) { # text
323 3         13 my $t = $2;
324 3         6 { local ${^MATCH}; $t =~ s/\s+$// }
  3         10  
  3         24  
325 3   50     34 $d->( "text " . ( $1 || 0 ) . " " . $t );
326             }
327             elsif ( /^([\r\n]+)/p ) {
328             # Silently ignore newlines.
329             }
330             elsif ( /^(.)/ps ) {
331 0         0 $d->( "ignore $1" );
332 0         0 warn( "Unhandled token: " . ${^MATCH} . "\n" );
333             }
334 481   66     1286 $dataxp .= $res // ${^MATCH};
335 481         943 $_ = ${^POSTMATCH};
336 481         1319 $index = $l0 - length($_);
337             }
338              
339 8         29 $self->{tokens} = [ map { $_->[0] } @d ];
  456         721  
340 8 50       46 $self->{raw_tokens} = [ @d ] if $self->{raw}; # USED?
341 8         41 $dataxp =~ s/\240/ /g;
342 8 100       36 $self->{dataxp} = $dataxp if $dataxp ne $self->{data};
343              
344 8         111 return $self->{tokens};
345             }
346              
347 1     1 0 85 sub chordqual { \%chordqual }
348              
349 21     21   10102 use Data::Struct;
  21         22487  
  21         44826  
350              
351             my @fields = qw( flags vs sz chord subchord text mark sign time lbar rbar alt );
352             struct Cell => @fields;
353              
354             sub make_cells {
355 1     1 0 2 my ( $self ) = @_;
356              
357 1         4 my $tokens = $self->tokens;
358 1         2 my $cells = [];
359 1         2 my $cell;
360 1         2 my $chordsize = 0; # normal
361 1         2 my $vspace = 0; # normal
362              
363             my $new_cell = sub {
364 75     75   142 $cell = struct "Cell";
365 75 50       1626 $cell->sz = $chordsize if $chordsize;
366 75         145 $cell->vs = $vspace; # always
367 75         755 push( @$cells, $cell );
368 1         5 };
369              
370             my $new_measure = sub {
371             # This is to make sure a bar on the beginning of a line has a
372             # corresponding bar on the end of the previous line.
373             # However, we cannot do that if there's a vertical shift
374             # involved.
375 29 50 33 29   92 if ( @$cells >= 2
376             &&
377             $cells->[-2]->vs == $cells->[-1]->vs
378             ) {
379 29   100     276 $cells->[-2]->rbar ||= "barlineSingle";
380             }
381 29   50     167 $cells->[-1]->lbar ||= "barlineSingle";
382 1         4 };
383              
384 1         3 $new_cell->(); # TODO section? measure?
385              
386 1         3 foreach my $t ( @$tokens ) {
387              
388 118 100       195 if ( $t eq "start section" ) {
389 1         3 $cell->lbar = "barlineDouble";
390 1         5 next;
391             }
392              
393 117 100       225 if ( $t eq "start repeat" ) {
394 3         7 $cell->lbar = "repeatLeft";
395 3         15 next;
396             }
397              
398 114 100       167 if ( $t eq "end repeat" ) {
399 3 50       14 $cells->[-2]->rbar = "repeatRight"
400             if @$cells >= 2;
401 3         13 next;
402             }
403              
404 111 100       207 if ( $t =~ /time (\d+)\/(\d+)/ ) {
405 1         5 $cell->time = [ $1, $2 ];
406 1         6 next;
407             }
408              
409 110 100       195 if ( $t =~ /^hspace\s+(\d+)$/ ) {
410 1         14 $new_cell->() for 1..$1;
411 1         2 next;
412             }
413              
414             # |Bh7 E7b9 ZY|QA- |
415 109 50       190 if ( $t eq "vspace" ) {
416 0         0 $vspace++;
417 0 0       0 $cells->[-1]->vs = $vspace
418             if @$cells >= 1;
419 0         0 next;
420             }
421              
422 109 100       161 if ( $t eq "end" ) {
423 1 50       6 $cells->[-2]->rbar = "barlineFinal"
424             if @$cells >= 2;
425 1         6 next;
426             }
427              
428 108 100       179 if ( $t eq "end section" ) {
429 2 50       7 $cells->[-2]->rbar = "barlineDouble"
430             if @$cells >= 2;
431 2         10 next;
432             }
433              
434 106 100       163 if ( $t eq "bar" ) {
435 29         51 $new_measure->();
436 29         170 next;
437             }
438              
439 77 100       209 if ( $t =~ /^(segno|coda|fermata)$/ ) {
440 3         7 $cell->sign = $1;
441 3         16 next;
442             }
443              
444 74 100       170 if ( $t =~ /^chord\s+(.*)$/ ) {
445 33         64 my $c = $1;
446              
447 33 50       63 if ( $c =~ s/\((.+)\)// ) {
448 0 0       0 if ( $c ) {
449 0         0 $cell->subchord = $1;
450             }
451             else {
452 0 0       0 $cells->[-2]->subchord = $1
453             if @$cells >= 2;
454 0         0 next;
455             }
456             }
457              
458 33         63 $cell->chord = $c;
459 33         167 $new_cell->();
460 33         56 next;
461             }
462              
463 41 100       76 if ( $t =~ /^alternative\s+(\d)$/ ) {
464 2         7 $cell->alt = $1;
465             }
466              
467 41 50       76 if ( $t eq "small" ) {
468 0         0 $cell->sz = $chordsize = 1;
469 0         0 next;
470             }
471              
472 41 50       69 if ( $t eq "large" ) {
473 0         0 $cell->sz = $chordsize = 0;
474 0         0 next;
475             }
476              
477 41 100       71 if ( $t =~ /^mark (.)/ ) {
478 3         9 $cell->mark = $1;
479 3         17 next;
480             }
481              
482 38 50       69 if ( $t eq "stop" ) {
483 0   0     0 $cell->flags = 0x01 | ($cell->flags||0); # WIP
484 0         0 next;
485             }
486              
487 38 100       63 if ( $t =~ /^text\s+(\d+)\s(.*)/ ) {
488 1         6 $cell->text = [ $1, $2 ];
489 1         6 next;
490             }
491              
492 37 100       114 if ( $t =~ /^advance\s+(\d+)$/ ) {
493 35         113 $new_cell->() for 1..$1;
494 35         55 next;
495             }
496              
497 2 50       5 if ( $t =~ /^measure repeat (single|double)$/ ) {
498 0 0       0 my $c = $1 eq "single" ? "repeat1Bar" : "repeat2Bars";
499 0         0 $cell->chord = $c;
500 0         0 $new_cell->();
501 0         0 next;
502             }
503              
504 2 50       6 if ( $t =~ /^slash repeat$/ ) {
505 0         0 $cell->chord = "repeatSlash";
506 0         0 $new_cell->();
507 0         0 next;
508             }
509              
510 2         4 next;
511              
512             }
513 1         10 return $self->{cells} = $cells;
514             }
515              
516             ################ Transposition ################
517              
518             my $notesS = [ split( ' ', "A A# B C C# D D# E F F# G G#" ) ];
519             my $notesF = [ split( ' ', "A Bb B C Db D Eb E F Gb G Ab" ) ];
520             my %notes = ( A => 1, B => 3, C => 4, D => 6, E => 8, F => 9, G => 11 );
521              
522             sub xpose {
523 183     183 0 382 my ( $self, $c ) = @_;
524 183 100       570 return $c unless my $xp = $self->{transpose} + $self->{_transpose};
525              
526 8 50       36 return $c unless $c =~ m/
527             ^ (
528             [CF](?:\#)? |
529             [DG](?:\#|b)? |
530             A(?:\#|b)? |
531             E(?:b)? |
532             B(?:b)?
533             )
534             (.*)
535             /x;
536 8         20 my ( $r, $rest ) = ( $1, $2 );
537 8 50       19 if ( $rest =~ m;^(.*)/(.*); ) {
538 0         0 $rest = $1 . "/" . $self->xpose($2);
539             }
540 8         13 my $mod = 0;
541 8 50       21 $mod-- if $r =~ s/b$//;
542 8 50       15 $mod++ if $r =~ s/\#$//;
543 8 50       22 warn("WRONG NOTE: '$c' '$r' '$rest'") unless $r = $notes{$r};
544 8         17 $r = ($r - 1 + $mod + $xp) % 12;
545 8 100       30 return ( $self->{transpose} > 0 ? $notesS : $notesF )->[$r] . $rest;
546             }
547              
548             my $_sigs;
549              
550             sub _timesig {
551 8     8   35 my ( $time_d, $time_n ) = @_;
552 8   50     199 $_sigs ||= { "22" => "2/2",
553             "32" => "3/2",
554             "24" => "2/4",
555             "34" => "3/4",
556             "44" => "4/4",
557             "54" => "5/4",
558             "64" => "6/4",
559             "74" => "7/4",
560             "28" => "2/8",
561             "38" => "3/8",
562             "48" => "4/8",
563             "58" => "5/8",
564             "68" => "6/8",
565             "78" => "7/8",
566             "98" => "9/8",
567             "12" => "12/8",
568             };
569              
570 8 50       68 $_sigs->{ "$time_d$time_n" }
571             || Carp::croak("Invalid time signature: $time_d/$time_n");
572             }
573              
574             ################ Exports ################
575              
576             sub as_string {
577 16     16 0 983 my ( $self ) = @_;
578              
579             join( "=",
580             $self->{title},
581             $self->{composer},
582             $self->{a2} || '',
583             $self->{style},
584             $self->{key},
585             $self->{actual_key} || '',
586             obfuscate( $self->{data} ),
587             $self->{actual_style} || '',
588             $self->{actual_tempo} || 0,
589 16   50     147 $self->{actual_repeats} || 0,
      50        
      100        
      50        
      100        
590             );
591             }
592              
593             sub export {
594 0     0 0 0 my ( $self, %args ) = @_;
595 0         0 Carp::carp(__PACKAGE__."::export is deprecated, please use 'as_string' instead");
596              
597 0   0     0 my $v = $args{variant} || $self->{variant} || "irealpro";
598 0         0 my $r;
599              
600 0 0       0 if ( $v eq "irealbook" ) {
601             $r = join( "=",
602             $self->{title},
603             $self->{composer},
604             $self->{style},
605             $self->{key},
606             $self->{a3} || '',
607             $self->{data},
608 0   0     0 );
609             }
610             else {
611 0         0 $r = $self->as_string;
612             }
613 0 0 0     0 if ( $args{html} || $args{uriencode} || !defined( $args{uriencode} ) ) {
      0        
614 0         0 $r = encode_utf8($r);
615 0         0 $r =~ s/([^-_.A-Z0-9a-z*\/\'])/sprintf("%%%02X", ord($1))/ge;
  0         0  
616             }
617 0         0 return $r;
618             }
619              
620             # Obfuscate...
621             # IN: [T44C |G |C |G Z
622             # OUT: 1r34LbKcu7[T44CXyQ|GXyQ|CXyQ|GXyQZ
623             sub obfuscate {
624 16 50   16 0 40 my ( $t ) = @_;die unless defined $t;
  16         41  
625 16         35 for ( $t ) {
626 16         131 s/ /XyQ/g; # obfuscating substitution
627 16         149 s/ \|/LZ/g; # obfuscating substitution
628 16         59 s/\| x/Kcl/g; # obfuscating substitution
629 16         45 $_ = hussle($_); # hussle
630 16         96 s/^/1r34LbKcu7/; # add magix prefix
631             }
632 16         285 $t;
633             }
634              
635             # Deobfuscate...
636             # IN: 1r34LbKcu7[T44CXyQ|GXyQ|CXyQ|GXyQZ
637             # OUT: [T44C |G |C |G Z
638             sub deobfuscate {
639 14     14 0 48 my ( $t ) = @_;
640 14         53 for ( $t ) {
641 14         110 s/^1r34LbKcu7//; # remove magix prefix
642 14         76 $_ = hussle($_); # hussle
643 14         121 s/XyQ/ /g; # obfuscating substitution
644 14         158 s/LZ/ |/g; # obfuscating substitution
645 14         66 s/Kcl/| x/g; # obfuscating substitution
646             }
647 14         47 $t;
648             }
649              
650             # Symmetric husseling.
651             sub hussle {
652 30     30 0 91 my ( $string ) = @_;
653 30         74 my $result = '';
654              
655 30         144 while ( length($string) > 50 ) {
656              
657             # Treat 50-byte segments.
658 84         257 my $segment = substr( $string, 0, 50, '' );
659 84 50       242 if ( length($string) < 2 ) {
660 0         0 $result .= $segment;
661 0         0 next;
662             }
663              
664             # Obfuscate a 50-byte segment.
665 84         441 $result .= reverse( substr( $segment, 45, 5 ) ) .
666             substr( $segment, 5, 5 ) .
667             reverse( substr( $segment, 26, 14 ) ) .
668             substr( $segment, 24, 2 ) .
669             reverse( substr( $segment, 10, 14 ) ) .
670             substr( $segment, 40, 5 ) .
671             reverse( substr( $segment, 0, 5 ) );
672             }
673              
674 30         101 return $result . $string;
675             }
676              
677             1;