Beginnings of strptime(). Do not touch the wet paint.

p4raw-id: //depot/perl@9853

diff --git a/ext/Time/Piece/Piece.pm b/ext/Time/Piece/Piece.pm
index 208b67f..64830f4 100644 (file)
--- a/ext/Time/Piece/Piece.pm
+++ b/ext/Time/Piece/Piece.pm
@@ -141,17 +141,25 @@ sub _mon {
     $time->[c_mon];
 }
 
+sub has_mon_names {
+    my $time = shift;
+    return 0;
+}
+
 sub monname {
     my $time = shift;
     if (@_) {
         return $_[$time->[c_mon]];
     }
-    elsif (@MON_NAMES) {
-        return $MON_NAMES[$time->[c_mon]];
-    }
-    else {
-        return $time->strftime('%b');
+    elsif ($time->has_mon_names) {
+        return $time->mon_name($time->[c_mon]);
     }
+    return $MON_NAMES[$time->[c_mon]];
+}
+
+sub has_month_names {
+    my $time = shift;
+    return 0;
 }
 
 sub monthname {
@@ -159,12 +167,10 @@ sub monthname {
     if (@_) {
         return $_[$time->[c_mon]];
     }
-    elsif (@MONTH_NAMES) {
-        return $MONTH_NAMES[$time->[c_mon]];
-    }
-    else {
-        return $time->strftime('%B');
+    elsif ($time->has_month_names) {
+        return $time->month_name($time->[c_mon]);
     }
+    return $MONTH_NAMES[$time->[c_mon]];
 }
 
 *month = \&monthname;
@@ -193,17 +199,25 @@ sub _wday {
 
 *day_of_week = \&_wday;
 
+sub has_wday_names {
+    my $time = shift;
+    return 0;
+}
+
 sub wdayname {
     my $time = shift;
     if (@_) {
         return $_[$time->[c_wday]];
     }
-    elsif (@WDAY_NAMES) {
-        return $WDAY_NAMES[$time->[c_wday]];
-    }
-    else {
-        return $time->strftime('%a');
+    elsif ($time->has_wday_names) {
+        return $time->wday_name($time->[c_mon]);
     }
+    return $WDAY_NAMES[$time->[c_wday]];
+}
+
+sub has_weekday_names {
+    my $time = shift;
+    return 0;
 }
 
 sub weekdayname {
@@ -211,12 +225,10 @@ sub weekdayname {
     if (@_) {
         return $_[$time->[c_wday]];
     }
-    elsif (@WEEKDAY_NAMES) {
-        return $WEEKDAY_NAMES[$time->[c_wday]];
-    }
-    else {
-        return $time->strftime('%A');
+    elsif ($time->has_weekday_names) {
+        return $time->weekday_name($time->[c_mon]);
     }
+    return $WEEKDAY_NAMES[$time->[c_wday]];
 }
 
 *weekdayname = \&weekdayname;
@@ -365,142 +377,179 @@ $_ftime =
      return "%";
  }, 
  'a' => sub {
-     my ($format, $time, @rest) = @_;
-     $time->wdayname(@rest);
+     my ($format, $time) = @_;
+     $time->wdayname();
  }, 
  'A' => sub {
-     my ($format, $time, @rest) = @_;
-     $time->weekdayname(@rest);
+     my ($format, $time) = @_;
+     $time->weekdayname();
  }, 
  'b' => sub {
-     my ($format, $time, @rest) = @_;
-     $time->monname(@rest);
+     my ($format, $time) = @_;
+     $time->monname();
  }, 
  'B' => sub {
-     my ($format, $time, @rest) = @_;
-     $time->monthname(@rest);
+     my ($format, $time) = @_;
+     $time->monthname();
  }, 
  'c' => sub {
-     my ($format, $time, @rest) = @_;
-     $time->cdate(@rest);
+     my ($format, $time) = @_;
+     $time->cdate();
  }, 
  'C' => sub {
-     my ($format, $time, @rest) = @_;
-     sprintf("%02d", int($time->y(@rest) / 100));
+     my ($format, $time) = @_;
+     sprintf("%02d", int($time->y() / 100));
  }, 
  'd' => sub {
-     my ($format, $time, @rest) = @_;
-     sprintf("%02d", $time->d(@rest));
+     my ($format, $time) = @_;
+     sprintf("%02d", $time->d());
  }, 
  'D' => sub {
-     my ($format, $time, @rest) = @_;
+     my ($format, $time) = @_;
      join("/",
-         $_ftime->{'m'}->('m', $time, @rest),
-         $_ftime->{'d'}->('d', $time, @rest),
-         $_ftime->{'y'}->('y', $time, @rest));
+         $_ftime->{'m'}->('m', $time),
+         $_ftime->{'d'}->('d', $time),
+         $_ftime->{'y'}->('y', $time));
  }, 
  'e' => sub {
-     my ($format, $time, @rest) = @_;
-     sprintf("%2d", $time->d(@rest));
+     my ($format, $time) = @_;
+     sprintf("%2d", $time->d());
  }, 
- 'f' => sub {
+ 'h' => sub {
      my ($format, $time, @rest) = @_;
      $time->monname(@rest);
  }, 
  'H' => sub {
-     my ($format, $time, @rest) = @_;
-     sprintf("%02d", $time->h(@rest));
+     my ($format, $time) = @_;
+     sprintf("%02d", $time->h());
  }, 
  'I' => sub {
-     my ($format, $time, @rest) = @_;
-     my $h = $time->h(@rest);
+     my ($format, $time) = @_;
+     my $h = $time->h();
      sprintf("%02d", $h == 0 ? 12 : ($h < 13 ? $h : $h % 12));
  }, 
  'j' => sub {
-     my ($format, $time, @rest) = @_;
-     sprintf("%03d", $time->yday(@rest));
+     my ($format, $time) = @_;
+     sprintf("%03d", $time->yday());
  }, 
  'm' => sub {
-     my ($format, $time, @rest) = @_;
-     sprintf("%02d", $time->mon(@rest));
+     my ($format, $time) = @_;
+     sprintf("%02d", $time->mon());
  }, 
  'M' => sub {
-     my ($format, $time, @rest) = @_;
-     sprintf("%02d", $time->min(@rest));
+     my ($format, $time) = @_;
+     sprintf("%02d", $time->min());
  }, 
  'n' => sub {
      return "\n";
  }, 
  'p' => sub {
-     my ($format, $time, @rest) = @_;
-     my $h = $time->h(@rest);
+     my ($format, $time) = @_;
+     my $h = $time->h();
      $h == 0 ? 'pm' : ($h < 13 ? 'am' : 'pm');
  }, 
  'r' => sub {
-     my ($format, $time, @rest) = @_;
+     my ($format, $time) = @_;
      join(":",
-         $_ftime->{'I'}->('I', $time, @rest),
-         $_ftime->{'M'}->('M', $time, @rest),
-         $_ftime->{'S'}->('S', $time, @rest)) .
-             " " . $_ftime->{'p'}->('p', $time, @rest);
+         $_ftime->{'I'}->('I', $time),
+         $_ftime->{'M'}->('M', $time),
+         $_ftime->{'S'}->('S', $time)) .
+             " " . $_ftime->{'p'}->('p', $time);
  }, 
  'R' => sub {
-     my ($format, $time, @rest) = @_;
+     my ($format, $time) = @_;
      join(":",
-         $_ftime->{'H'}->('H', $time, @rest),
-         $_ftime->{'M'}->('M', $time, @rest));
+         $_ftime->{'H'}->('H', $time),
+         $_ftime->{'M'}->('M', $time));
  }, 
  'S' => sub {
-     my ($format, $time, @rest) = @_;
-     sprintf("%02d", $time->s(@rest));
+     my ($format, $time) = @_;
+     sprintf("%02d", $time->s());
  }, 
  't' => sub {
      return "\t";
  }, 
  'T' => sub {
-     my ($format, $time, @rest) = @_;
+     my ($format, $time) = @_;
      join(":",
-         $_ftime->{'H'}->('H', $time, @rest),
-         $_ftime->{'M'}->('M', $time, @rest),
-         $_ftime->{'S'}->('S', $time, @rest));
+         $_ftime->{'H'}->('H', $time),
+         $_ftime->{'M'}->('M', $time),
+         $_ftime->{'S'}->('S', $time));
  }, 
  'u' => sub {
-     my ($format, $time, @rest) = @_;
-     ($time->wday(@rest) + 5) % 7 + 1;
+     my ($format, $time) = @_;
+     ($time->wday() + 5) % 7 + 1;
  }, 
+ # U taken care by libc
  'V' => sub {
-     my ($format, $time, @rest) = @_;
-     sprintf("%02d", $time->week(@rest));
+     my ($format, $time) = @_;
+     sprintf("%02d", $time->week());
  }, 
  'w' => sub {
-     my ($format, $time, @rest) = @_;
-     $time->_wday(@rest);
+     my ($format, $time) = @_;
+     $time->_wday();
  }, 
+ # W taken care by libc
  'x' => sub {
-     my ($format, $time, @rest) = @_;
+     my ($format, $time) = @_;
      join("/",
-         $_ftime->{'m'}->('m', $time, @rest),
-         $_ftime->{'d'}->('d', $time, @rest),
-         $_ftime->{'y'}->('y', $time, @rest));
+         $_ftime->{'m'}->('m', $time),
+         $_ftime->{'d'}->('d', $time),
+         $_ftime->{'y'}->('y', $time));
  },
  'y' => sub {
-     my ($format, $time, @rest) = @_;
-     sprintf("%02d", $time->y(@rest) % 100);
+     my ($format, $time) = @_;
+     sprintf("%02d", $time->y() % 100);
  }, 
  'Y' => sub {
-     my ($format, $time, @rest) = @_;
-     sprintf("%4d", $time->y(@rest));
+     my ($format, $time) = @_;
+     sprintf("%4d", $time->y());
  }, 
+ # Z taken care by libc
 };
 
+sub has_ftime {
+    my ($format) = @_;
+    exists $_ftime->{$format};
+}
+
+sub has_ftimes {
+    keys %$_ftime;
+}
+
+sub delete_ftime {
+    delete $_ftime->{@_};
+}
+
+sub ftime {
+    my ($format) = $_[0];
+    if (@_ == 1) {
+       return $_ftime->{$format};
+    } elsif (@_ == 2) {
+       if (ref $_[0] eq 'CODE') {
+           $_ftime->{$format} = $_[1];
+       } else {
+           require Carp;
+           Carp::croak "ftime: second argument not a code ref";
+       }
+    } else {
+       require Carp;
+       Carp::croak "ftime: want one or two arguments";
+    }
+}
+
 sub _ftime {
     my ($format, $time, @rest) = @_;
-    if (exists $_ftime->{$format}) {
+    if (has_ftime($format)) {
        # We are passing format to the anonsubs so that
        # one can share the same sub among several formats.
        return $_ftime->{$format}->($format, $time, @rest);
     }
-    return $time->_strftime("%$format"); # cheat
+    # If we don't know it, pass it down to the libc layer.
+    # (In other words, cheat.)
+    # This pays for for '%Z', though, and for all the
+    # locale-specific %Ex and %Oy formats.
+    return $time->_strftime("%$format");
 }
 
 sub strftime {
@@ -516,6 +565,94 @@ sub _strftime {
     return __strftime($format, (@$time)[c_sec..c_isdst]);
 }
 
+use vars qw($_ptime);
+
+$_ptime =
+{
+ '%' => sub {
+     $_[1] =~ s/^(%)// && $1;
+ },
+ 'd' => sub {
+     $_[1] =~ s/^(0[1-9]|2[0-9]|3[01])// && $1;
+ },
+ 'H' => sub {
+     $_[1] =~ s/^([0-1][0-9]|2[0-3])// && $1;
+ },
+ 'm' => sub {
+     $_[1] =~ s/^(0[1-9]|1[012])// && $1;
+ },
+ 'M' => sub {
+     $_[1] =~ s/^([0-5][0-9])// && $1;
+ },
+ 'S' => sub {
+     $_[1] =~ s/^([0-5][0-9])// && $1;
+ },
+ 'Y' => sub {
+     $_[1] =~ s/^([1-9][0-9][0-9][0-9])// && $1;
+ },
+};
+
+sub has_ptime {
+    my ($format) = @_;
+    exists $_ptime->{$format};
+}
+
+sub has_ptimes {
+    keys %$_ptime;
+}
+
+sub delete_ptime {
+    delete $_ptime->{@_};
+}
+
+sub ptime {
+    my ($format) = $_[0];
+    if (@_ == 1) {
+       return $_ptime->{$format};
+    } elsif (@_ == 2) {
+       if (ref $_[0] eq 'CODE') {
+           $_ptime->{$format} = $_[1];
+       } else {
+           require Carp;
+           Carp::croak "ptime: second argument not a code ref";
+       }
+    } else {
+       require Carp;
+       Carp::croak "ptime: want one or two arguments";
+    }
+}
+
+sub _ptime {
+    my ($format, $stime) = @_;
+    if (has_ptime($format)) {
+       # We are passing format to the anonsubs so that
+       # one can share the same sub among several formats.
+       return $_ptime->{$format}->($format, $stime);
+    }
+    die "strptime: unknown format %$format (time '$stime')\n";
+}
+
+sub strptime {
+    my $time   = shift;
+    my $format = shift;
+    my $stime =  @_ ? shift : "$time";
+    my %ptime;
+    while ($format ne '') {
+       if ($format =~ s/^([^%]+)//) {
+           my $skip = $1;
+           last unless $stime =~ s/^\Q$skip//;
+       }
+       while ($format =~ s/^%(.)//) {
+           my $t = _ptime($1, $stime);
+           if (defined $t) {
+               $ptime{$1} = $t;
+               substr($stime, 0, length($t)) = '';
+           }
+       }
+    }
+    return %ptime;
+}
+
 sub wday_names {
     shift if ref($_[0]) && $_[0]->isa(__PACKAGE__); # strip first if called as a method
     my @old = @WDAY_NAMES;

diff --git a/t/lib/time-piece.t b/t/lib/time-piece.t
index 777b25b..fcb64e6 100644 (file)
--- a/t/lib/time-piece.t
+++ b/t/lib/time-piece.t
@@ -267,12 +267,12 @@ print "ok 74\n";
 
 my @days = $t->weekday_names();
 
-$t->weekday_names(@frdays);
+Time::Piece::weekday_names(@frdays);
 
 print "not " unless $t->weekday eq "Merdi";
 print "ok 75\n";
 
-$t->weekday_names(@days);
+Time::Piece::weekday_names(@days);
 
 print "not " unless $t->weekday eq "Tuesday";
 print "ok 76\n";
@@ -285,12 +285,12 @@ my @dumonths = qw(januari februari maart april mei juni
 print "not " unless $t->month(@dumonths) eq "februari";
 print "ok 77\n";
 
-$t->month_names(@dumonths);
+Time::Piece::month_names(@dumonths);
 
 print "not " unless $t->month eq "februari";
 print "ok 78\n";
 
-$t->mon_names(@months);
+Time::Piece::mon_names(@months);
 
 print "not " unless $t->monname eq "Feb";
 print "ok 79\n";