File Coverage

blib/lib/Gtk2/Ex/Clock.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

# Copyright 2007, 2008, 2009, 2010, 2011 Kevin Ryde

# This file is part of Gtk2-Ex-Clock.
#
# Gtk2-Ex-Clock is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the Free
# Software Foundation; either version 3, or (at your option) any later
# version.
#
# Gtk2-Ex-Clock is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with Gtk2-Ex-Clock.  If not, see .

package Gtk2::Ex::Clock;
use 5.008;
use strict;
use warnings;
use Gtk2 1.200; # version 1.200 for GDK_PRIORITY_REDRAW
use POSIX ();
use POSIX::Wide 2; # version 2 for netbsd 646 alias
use List::Util qw(min);
use Scalar::Util;
use Time::HiRes;
use Glib::Ex::SourceIds;

# uncomment this to run the ### lines
#use Smart::Comments;

our $VERSION = 15;

use constant _DEFAULT_FORMAT => '%H:%M';

use Glib::Object::Subclass
  'Gtk2::Label',
  properties => [Glib::ParamSpec->string
                 ('format',
                  'Format string',
                  'An strftime() format string to display the time.',
                  _DEFAULT_FORMAT,
                  Glib::G_PARAM_READWRITE),

                 Glib::ParamSpec->scalar
                 ('timezone',
                  'Timezone',
                  'The timezone to use in the display, either a string for the TZ environment variable, or a DateTime::TimeZone object.  An empty string or undef means the local timezone.',
                  Glib::G_PARAM_READWRITE),

                 Glib::ParamSpec->string
                 ('timezone-string',
                  'Timezone string',
                  'The timezone to use in the display, as a string for the TZ environment variable.  An empty string or undef means the local timezone.',
                   (eval {Glib->VERSION(1.240);1}
                    ? undef # default
                    : ''),  # no undef/NULL before Perl-Glib 1.240
                  Glib::G_PARAM_READWRITE),

                 Glib::ParamSpec->int
                 ('resolution',
                  'Resolution',
                  'The resolution of the clock, in seconds, or 0 to decide this from the format string.',
                  0,     # min
                  3600,  # max
                  0,     # default
                  Glib::G_PARAM_READWRITE),
                ];


# _TIMER_MARGIN_MILLISECONDS is an extra period in milliseconds to add to
# the timer period requested.  It's designed to ensure the timer doesn't
# fire before the target time boundary of 1 second or 1 minute, in case
# g_timeout_add() or the select() within it ends up rounding down to a clock
# tick boundary.
#
# In the unlikely event there's no sysconf() value for CLK_TCK, or no
# sysconf() func at all, assume the traditional 100 ticks/second, ie. a
# resolution of 10 milliseconds, giving a 20 ms margin.
#
use constant _TIMER_MARGIN_MILLISECONDS => do {
  my $clk_tck = -1;  # default -1 like the error return from sysconf()
  ## no critic (RequireCheckingReturnValueOfEval)
  eval { $clk_tck = POSIX::sysconf (POSIX::_SC_CLK_TCK()); };
  ### $clk_tck
  if ($clk_tck <= 0) { $clk_tck = 100; } # default assume 100 Hz, 10ms tick
  (2 * 1000.0 / $clk_tck)
};
### _TIMER_MARGIN_MILLISECONDS: _TIMER_MARGIN_MILLISECONDS()


sub INIT_INSTANCE {
  my ($self) = @_;
  $self->{'format'} = _DEFAULT_FORMAT;
  $self->{'resolution'} = 0; # per pspec default
  $self->{'decided_resolution'} = 60; # of _DEFAULT_FORMAT
  $self->set_use_markup (1);
  _update($self);  # initial string for initial size
}

sub GET_PROPERTY {
  my ($self, $pspec) = @_;
  my $pname = $pspec->get_name;

  if ($pname eq 'timezone_string') {
    my $timezone = $self->{'timezone'};
    # For DateTime::TimeZone read back the ->name() string.
    # Not yet documented.  Is this a good idea?
    if (Scalar::Util::blessed ($timezone)) {
      $timezone = $timezone->name;
    }
    return $timezone;
  }

  return $self->{$pname};
}

sub SET_PROPERTY {
  my ($self, $pspec, $newval) = @_;
  ### Clock SET_PROPERTY: $pspec->get_name

  my $pname = $pspec->get_name;
  if ($pname eq 'timezone_string') {  # alias
    $pname = 'timezone';
  }
  $self->{$pname} = $newval;  # per default GET_PROPERTY

  if ($pname eq 'timezone') {
    if (Scalar::Util::blessed($newval)
        && $newval->isa('DateTime::TimeZone')) {
      require DateTime;
    } elsif (defined $newval && $newval ne '') {
      require Tie::TZ;
    }
  }

  if ($pname eq 'resolution' || $pname eq 'format') {
    $self->{'decided_resolution'}
      = $self->get('resolution')
        || ($self->strftime_is_seconds($self->{'format'}) ? 1 : 60);
    ### decided resolution: $self->{'decided_resolution'}
  }
  if ($pname eq 'timezone' || $pname eq 'format') {
    _update ($self);
  }
}

sub _timer_callback {
  my ($ref_weak_self) = @_;
  ### _timer_callback()
  my $self = $$ref_weak_self || return 0; # Glib::SOURCE_REMOVE

  _update ($self);

  # this timer should be removed by SourceIds anyway
  return 0; # Glib::SOURCE_REMOVE
}

# set the label string and start or restart timer
sub _update {
  my ($self) = @_;
  ### Clock _update()

  my $tod = Time::HiRes::time();
  my $format   = $self->{'format'};
  my $timezone = $self->{'timezone'};

  my ($str, $minute, $second);
  if (Scalar::Util::blessed($timezone)
      && $timezone->isa('DateTime::TimeZone')) {
    my $t = DateTime->from_epoch (epoch => $tod, time_zone => $timezone);
    $str = $t->strftime ($format);
    $minute = $t->minute;
    $second = $t->second;
  } else {
    my @tm;
    if (defined $timezone && $timezone ne '') {
      ### using TZ: $timezone
      no warnings 'once';
      local $Tie::TZ::TZ = $timezone;
      @tm = localtime ($tod);
      $str = POSIX::Wide::strftime ($format, @tm);
    } else {
      ### using current timezone
      @tm = localtime ($tod);
      $str = POSIX::Wide::strftime ($format, @tm);
    }
    $minute = $tm[1];
    $second = $tm[0];
  }
  $self->set_label ($str);

  # Decide how long in milliseconds until the next update.  This is from the
  # current $minute,$second,frac($tod) to the next multiple of
  # $self->{'decided_resolution'} seconds, plus _TIMER_MARGIN_MILLISECONDS
  # described above.
  #
  # If $self->{'decided_resolution'} is 1 second then $minute,$second have
  # no effect and it's just from the fractional part of $tod to the next 1
  # second.  Similarly if $self->{'decided_resolution'} is 60 seconds then
  # $minute has no effect.
  #
  # Rumour has it $second can be 60 for some oddity like a TAI system clock
  # displaying UTC.  Dunno if it really happens, but cap at 59 just in case.
  #
  # In theory an mktime of $second+1, or $minute+1,$second=0, would be the
  # $tod value to target.  Not absolutely certain that would come out right
  # if crossing a daylight savings boundary, though capping it modulo the
  # resolution like ($newtod - $tod) % $self->{'decided_resolution'} would
  # ensure a sensible range.  Would an mktime be worthwhile?  Taking just
  # 60*$minute+$second is a little less work.
  #
  my $milliseconds = POSIX::ceil
    (_TIMER_MARGIN_MILLISECONDS
     + (1000
        * ($self->{'decided_resolution'}
           - ((60*$minute + min(59,$second)) % $self->{'decided_resolution'})
           - ($tod - POSIX::floor($tod))))); # fraction part

  ### timer: "$tod is $minute,$second wait $milliseconds to give ".($tod + $milliseconds / 1000.0)
  Scalar::Util::weaken (my $weak_self = $self);
  $self->{'timer'} = Glib::Ex::SourceIds->new
    (Glib::Timeout->add ($milliseconds,
                         \&_timer_callback, \$weak_self,
                         Gtk2::GDK_PRIORITY_REDRAW() - 1));  # before redraws

}


#------------------------------------------------------------------------------

# $format is an strftime() format string.  Return true if it has 1 second
# resolution.
#
sub strftime_is_seconds {
  my ($self, $format) = @_;

  # %c is ctime() style, includes seconds
  # %r is "%I:%M:%S %p"
  # %s is seconds since 1970 (a GNU extension)
  # %S is seconds 0 to 59
  # %T is "%H:%M:%S"
  # %X is locale preferred time, probably "%H:%M:%S"
  # modifiers standard E and O, plus GNU "-_0^"
  #
  # DateTime extras:
  #   %N is nanoseconds, which really can't work, so ignore
  #
  # DateTime methods:
  #   second()
  #   sec()
  #   hms(), time()
  #   datetime(), is8601()
  #   epoch()
  #   utc_rd_as_seconds()
  #
  #   jd(), mjd() fractional part represents the time, but the decimals
  #   aren't a whole second so won't really display properly, ignore for now
  #
  $format =~ s/%%//g; # literal "%"s, so eg. "%%Something" is not "%S"
  return ($format =~ /%[-_^0-9EO]*
                       ([crsSTX]
                       |\{(sec(ond)?|hms|(date)?time|iso8601|epoch|utc_rd_as_seconds)})/x);
}

1;
__END__