local-lib5/lib/perl5/String/RewritePrefix.pm

   1 use strict;
   2 use warnings;
   3 package String::RewritePrefix;
   4 use Carp ();
   5
   6 use Sub::Exporter -setup => {
   7   exports => [ rewrite => \'_new_rewriter' ],
   8 };
   9
  10 =head1 NAME
  11
  12 String::RewritePrefix - rewrite strings based on a set of known prefixes
  13
  14 =head1 VERSION
  15
  16 version 0.005
  17
  18 =head1 SYNOPSIS
  19
  20   use String::RewritePrefix;
  21   my @to_load = String::RewritePrefix->rewrite(
  22     { '' => 'MyApp::', '+' => '' },
  23     qw(Plugin Mixin Addon +Corporate::Thinger),
  24   );
  25
  26   # now you have:
  27   qw(MyApp::Plugin MyApp::Mixin MyApp::Addon Corporate::Thinger)
  28
  29 You can also import a rewrite routine:
  30
  31   use String::RewritePrefix rewrite => {
  32     -as => 'rewrite_dt_prefix',
  33     prefixes => { '' => 'MyApp::', '+' => '' },
  34   };
  35
  36   my @to_load = rewrite_dt_prefix( qw(Plugin Mixin Addon +Corporate::Thinger));
  37
  38   # now you have:
  39   qw(MyApp::Plugin MyApp::Mixin MyApp::Addon Corporate::Thinger)
  40
  41 =cut
  42
  43 our $VERSION = '0.005';
  44
  45 =head1 METHODS
  46
  47 =head2 rewrite
  48
  49   String::RewritePrefix->rewrite(\%prefix, @strings);
  50
  51 This rewrites all the given strings using the rules in C<%prefix>.  Its keys
  52 are known prefixes for which its values will be substituted.  This is performed
  53 in longest-first order, and only one prefix will be rewritten.
  54
  55 If the prefix value is a coderef, it will be executed with the remaining string
  56 as its only argument.  The return value will be used as the prefix.
  57
  58 =cut
  59
  60 sub rewrite {
  61   my ($self, $arg, @rest) = @_;
  62   return $self->_new_rewriter(rewrite => { prefixes => $arg })->(@rest);
  63 }
  64
  65 sub _new_rewriter {
  66   my ($self, $name, $arg) = @_;
  67   my $rewrites = $arg->{prefixes} || {};
  68
  69   my @rewrites;
  70   for my $prefix (sort { length $b <=> length $a } keys %$rewrites) {
  71     push @rewrites, ($prefix, $rewrites->{$prefix});
  72   }
  73
  74   return sub {
  75     my @result;
  76
  77     Carp::cluck("string rewriter invoked in void context")
  78       unless defined wantarray;
  79
  80     Carp::croak("attempt to rewrite multiple strings outside of list context")
  81       if @_ > 1 and ! wantarray;
  82
  83     STRING: for my $str (@_) {
  84       for (my $i = 0; $i < @rewrites; $i += 2) {
  85         if (index($str, $rewrites[$i]) == 0) {
  86           if (ref $rewrites[$i+1]) {
  87             my $rest = substr $str, length($rewrites[$i]);
  88             push @result, $rewrites[$i+1]->($rest) . $rest;
  89           } else {
  90             push @result, $rewrites[$i+1] . substr $str, length($rewrites[$i]);
  91           }
  92           next STRING;
  93         }
  94       }
  95
  96       push @result, $str;
  97     }
  98
  99     return wantarray ? @result : $result[0];
 100   };
 101 }
 102
 103 =head1 AUTHOR
 104
 105 Ricardo SIGNES <rjbs@cpan.org>
 106
 107 =head1 COPYRIGHT AND LICENSE
 108
 109 This software is copyright (c) 2008 by Ricardo SIGNES.
 110
 111 This is free software; you can redistribute it and/or modify it under
 112 the same terms as perl itself.
 113
 114 =cut
 115
 116 1;