SL/PrefixedNumber.pm

   1 package SL::PrefixedNumber;
   2
   3 use strict;
   4
   5 use parent qw(Rose::Object);
   6
   7 use Carp;
   8 use List::Util qw(max);
   9
  10 use Rose::Object::MakeMethods::Generic
  11 (
  12  scalar                  => [ qw(number) ],
  13  'scalar --get_set_init' => [ qw(_state) ],
  14 );
  15
  16 sub init__state {
  17   my ($self) = @_;
  18
  19   croak "No 'number' set" if !defined($self->number);
  20
  21   my @matches    = $self->number =~ m/^(.*?)(\d+)$/;
  22   my @matches2   = $self->number =~ m/^(.*[^\d])$/;
  23   my $prefix     =  @matches2 ? $matches2[0] : (2 != scalar(@matches)) ? '' : $matches[ 0],;
  24   my $ref_number = !@matches  ? '0'          : $matches[-1];
  25   my $min_places = length $ref_number;
  26
  27   return {
  28     prefix     => $prefix,
  29     ref_number => $ref_number,
  30     min_places => $min_places,
  31   };
  32 }
  33
  34 sub get_current {
  35   my ($self) = @_;
  36
  37   return $self->format($self->_state->{ref_number});
  38 }
  39
  40 sub get_next {
  41   my ($self) = @_;
  42
  43   return $self->set_to($self->_state->{ref_number} + 1);
  44 }
  45
  46 sub format {
  47   my ($self, $number) = @_;
  48
  49   my $state           = $self->_state;
  50   $number             =~ s/\.\d+//g;
  51
  52   return $state->{prefix} . ('0' x max($state->{min_places} - length($number), 0)) . $number;
  53 }
  54
  55 sub set_to {
  56   my ($self, $new_number) = @_;
  57
  58   my $state            = $self->_state;
  59   $state->{ref_number} = $new_number;
  60
  61   return $self->number($self->format($new_number));
  62 }
  63
  64 sub set_to_max {
  65   my ($self, @numbers) = @_;
  66
  67   return $self->set_to(max map { SL::PrefixedNumber->new(number => $_ // 0)->_state->{ref_number} } @numbers);
  68 }
  69
  70 1;
  71 __END__
  72
  73 =pod
  74
  75 =encoding utf8
  76
  77 =head1 NAME
  78
  79 SL::PrefixedNumber - Increment a number prefixed with some text
  80
  81 =head1 SYNOPSIS
  82
  83   my $number = SL::PrefixedNumber->new(number => 'FB000042')->get_next;
  84   print $number; # FB000043
  85
  86 =head1 FUNCTIONS
  87
  88 =over 4
  89
  90 =item C<format $number>
  91
  92 Returns C<$number> formatted according to the rules in C<$self>. Does
  93 not modify C<$self>. E.g.
  94
  95   my $sequence = SL::PrefixedNumber->new('FB12345');
  96   print $sequence->format(42); # FB00042
  97   print $sequence->get_next;   # FB12346
  98
  99 =item C<get_current>
 100
 101 Returns the current number in the sequence (formatted). Does not
 102 modify C<$self>.
 103
 104 =item C<get_next>
 105
 106 Returns the next number in the sequence (formatted). Modifies C<$self>
 107 accordingly so that calling C<get_next> multiple times will actually
 108 iterate over the sequence.
 109
 110 =item C<set_to $number>
 111
 112 Sets the current postfix to C<$number> but does not change the
 113 prefix. Returns the formatted new number. E.g.:
 114
 115   my $sequence = SL::PrefixedNumber->new(number => 'FB000042');
 116   print $sequence->set_to(123); # FB000123
 117   print $sequence->get_next;    # FB000124
 118
 119 =item C<set_to_max @numbers>
 120
 121 Sets the current postfix to the maximum of all the numbers listed in
 122 C<@numbers>. All those numbers can be prefixed numbers. Returns the
 123 formatted maximum number. E.g.
 124
 125   my $sequence = SL::PrefixedNumber->new(number => 'FB000042');
 126   print $sequence->set_to_max('FB000123', 'FB999', 'FB00001'); # FB000999
 127   print $sequence->get_next;                                   # FB001000
 128
 129 =back
 130
 131 =head1 BUGS
 132
 133 Nothing here yet.
 134
 135 =head1 AUTHOR
 136
 137 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
 138
 139 =cut