view release on metacpan or  search on metacpan

lib/DateTime/Format/Lite.pm  view on Meta::CPAN

    my( $years, $months, $weeks, $days, $hours, $minutes, $seconds ) =
        map{ defined( $_ ) ? do{ ( my $v = $_ ) =~ s/,/./; $v + 0 } : 0 }
        ( $1, $2, $3, $4, $5, $6, $7 );

    # Fold weeks into days (ISO 8601 weeks are always exactly 7 days)
    $days += $weeks * 7;

    return( DateTime::Lite::Duration->new(
        years   => $years,
        months  => $months,
        days    => $days,
        hours   => $hours,
        minutes => $minutes,
        seconds => $seconds,
    ) );
}

sub pass_error
{
    my $self = shift( @_ );
    my $pack = ref( $self ) || $self;
    my $opts = {};
    my( $err, $class, $code );
    no strict 'refs';
    if( scalar( @_ ) )
    {
        # Either an hash defining a new error and this will be passed along to error(); or
        # an hash with a single property: { class => 'Some::ExceptionClass' }
        if( scalar( @_ ) == 1 && ref( $_[0] ) eq 'HASH' )
        {
            $opts = $_[0];
        }
        else
        {
            if( scalar( @_ ) > 1 && ref( $_[-1] ) eq 'HASH' )
            {
                $opts = pop( @_ );
            }
            $err = $_[0];
        }
    }
    $err = $opts->{error} if( !defined( $err ) && CORE::exists( $opts->{error} ) && defined( $opts->{error} ) && CORE::length( $opts->{error} ) );
    # We set $class only if the hash provided is a one-element hash and not an error-defining hash
    $class = $opts->{class} if( CORE::exists( $opts->{class} ) && defined( $opts->{class} ) && CORE::length( $opts->{class} ) );
    $code  = $opts->{code} if( CORE::exists( $opts->{code} ) && defined( $opts->{code} ) && CORE::length( $opts->{code} ) );

    # called with no argument, most likely from the same class to pass on an error 
    # set up earlier by another method; or
    # with an hash containing just one argument class => 'Some::ExceptionClass'
    if( !defined( $err ) && ( !scalar( @_ ) || defined( $class ) ) )
    {
        # $error is a previous erro robject
        my $error = ref( $self ) ? $self->{error} : length( ${ $pack . '::ERROR' } ) ? ${ $pack . '::ERROR' } : undef;
        if( !defined( $error ) )
        {
            warn( "No error object provided and no previous error set either! It seems the previous method call returned a simple undef" );
        }
        else
        {
            $err = ( defined( $class ) ? bless( $error => $class ) : $error );
            $err->code( $code ) if( defined( $code ) );
        }
    }
    elsif( defined( $err ) && 
           Scalar::Util::blessed( $err ) && 
           ( scalar( @_ ) == 1 || 
             ( scalar( @_ ) == 2 && defined( $class ) ) 
           ) )
    {
        $self->{error} = ${ $pack . '::ERROR' } = ( defined( $class ) ? bless( $err => $class ) : $err );
        $self->{error}->code( $code ) if( defined( $code ) && $self->{error}->can( 'code' ) );

        # Use $pack (always defined) not $class (only set when explicitly provided)
        # to check for FATAL_EXCEPTIONS, to avoid "uninitialized value" warnings.
        my $check_class = $class // $pack;
        if( $self->{fatal} || ( defined( ${"${check_class}::FATAL_EXCEPTIONS"} ) && ${"${check_class}::FATAL_EXCEPTIONS"} ) )
        {
            die( $self->{error} );
        }
    }
    # If the error provided is not an object, we call error to create one
    else
    {
        return( $self->error( @_ ) );
    }

    if( want( 'OBJECT' ) )
    {
        rreturn( DateTime::Format::Lite::NullObject->new );
    }
    return;
}

sub pattern
{
    my $self = shift( @_ );
    if( @_ )
    {
        my $pat = shift( @_ );
        unless( defined( $pat ) && length( $pat ) )
        {
            return( $self->error( "pattern must be a non-empty string." ) );
        }
        $self->{pattern} = $pat;
        # Invalidate cached parser
        $self->{_parser} = undef;
    }
    return( $self->{pattern} );
}

sub strict
{
    my $self = shift( @_ );
    $self->{strict} = $_[0] ? 1 : 0 if( @_ );
    return( $self->{strict} );
}

# NOTE: strftime() -> Exportable convenience function
sub strftime
{
    my( $pattern, $dt ) = @_;
    my $fmt = __PACKAGE__->new( pattern => $pattern ) ||
        die( __PACKAGE__->error );
    return( $fmt->format_datetime( $dt ) );
}

# NOTE: strptime() -> Exportable convenience function
sub strptime
{
    my( $pattern, $string ) = @_;