view release on metacpan or  search on metacpan

lib/Module/Generic/Finfo.pm  view on Meta::CPAN

{
    my $self = shift( @_ );
    my $data = $self->{_data};
    return( want( 'OBJECT' ) ? Module::Generic::Null->new : '' ) if( !scalar( @$data ) );
    return( $self->new_number( sprintf( '%04o', $data->[ FINFO_MODE ] & 07777 ) ) );
}

sub protection
{
    my $self = shift( @_ );
    my @stat = CORE::stat( $self->filepath );
    return( want( 'OBJECT' ) ? Module::Generic::Null->new : '' ) if( !scalar( @stat ) );
    return( $self->new_number( hex( sprintf( '%04o', $stat[2] & 07777 ) ) ) );
}

sub rdev
{
    my $self = shift( @_ );
    my $data = $self->{_data};
    return( want( 'OBJECT' ) ? Module::Generic::Null->new : '' ) if( !scalar( @$data ) );
    return( $self->new_number( $data->[ FINFO_RDEV ] ) );
}

sub reset
{
    my $self = shift( @_ );
    my $file = $self->filepath;
    $self->{_data} = [CORE::stat( $file )];
    return( $self );
}

sub size
{
    my $self = shift( @_ );
    my $data = $self->{_data};
    return( want( 'OBJECT' ) ? Module::Generic::Null->new : '' ) if( !scalar( @$data ) );
    return( $self->new_number( $data->[ FINFO_SIZE ] ) );
}

sub stat
{
    my $self = shift( @_ );
    my $file = shift( @_ );
    my $p = scalar( @_ ) ? { @_ } : {};
    return( $self->new( $file, $p ) );
}

sub uid
{
    my $self = shift( @_ );
    my $data = $self->{_data};
    return( want( 'OBJECT' ) ? Module::Generic::Null->new : '' ) if( !scalar( @$data ) );
    return( $self->new_number( $data->[ FINFO_UID ] ) );
}

sub user
{
    my $self = shift( @_ );
    my $data = $self->{_data};
    return( want( 'OBJECT' ) ? Module::Generic::Null->new : '' ) if( !scalar( @$data ) );
    # perlport: "getpwuid: (Win32) Not implemented. (RISC OS) Not useful.
    return( $self->uid ) if( $^O =~ /^(win32|riscok)/i );
    return( $self->new_scalar( scalar( getpwuid( $data->[ FINFO_UID ] ) ) ) );
}

sub DESTROY
{
    # <https://perldoc.perl.org/perlobj#Destructors>
    CORE::local( $., $@, $!, $^E, $? );
    CORE::return if( ${^GLOBAL_PHASE} eq 'DESTRUCT' );
    my $self = CORE::shift( @_ );
    CORE::return if( !CORE::defined( $self ) );
    my $repo = Module::Generic::Global->new( 'local_tz' => 'system' );
    $repo->cleanup;
};

sub FREEZE
{
    my $self = CORE::shift( @_ );
    my $serialiser = CORE::shift( @_ ) // '';
    my $class = CORE::ref( $self );
    my @props = qw( filepath _data );
    my $hash  = {};
    foreach my $prop ( @props )
    {
        if( CORE::exists( $self->{ $prop } ) )
        {
            $hash->{ $prop } = $self->{ $prop };
        }
    }
    # Return an array reference rather than a list so this works with Sereal and CBOR
    # On or before Sereal version 4.023, Sereal did not support multiple values returned
    if( $serialiser eq 'Sereal' )
    {
        require Sereal::Encoder;
        require version;
    
        if( version->parse( Sereal::Encoder->VERSION ) <= version->parse( '4.023' ) )
        {
            CORE::return( [$class, $hash] );
        }
    }
    # But Storable want a list with the first element being the serialised element
    CORE::return( $class, $hash );
}

sub STORABLE_freeze { CORE::return( CORE::shift->FREEZE( @_ ) ); }

sub STORABLE_thaw { CORE::return( CORE::shift->THAW( @_ ) ); }

# NOTE: CBOR will call the THAW method with the stored classname as first argument, the constant string CBOR as second argument, and all values returned by FREEZE as remaining arguments.
# NOTE: Storable calls it with a blessed object it created followed with $cloning and any other arguments initially provided by STORABLE_freeze
sub THAW
{
    my( $self, undef, @args ) = @_;
    my $ref = ( CORE::scalar( @args ) == 1 && CORE::ref( $args[0] ) eq 'ARRAY' ) ? CORE::shift( @args ) : \@args;
    my $class = ( CORE::defined( $ref ) && CORE::ref( $ref ) eq 'ARRAY' && CORE::scalar( @$ref ) > 1 ) ? CORE::shift( @$ref ) : ( CORE::ref( $self ) || $self );
    my $hash = CORE::ref( $ref ) eq 'ARRAY' ? CORE::shift( @$ref ) : {};
    my $new;
    # Storable pattern requires to modify the object it created rather than returning a new one
    if( CORE::ref( $self ) )
    {
        foreach( CORE::keys( %$hash ) )