From Code to Community: Sponsoring The Perl and Raku Conference 2025 Learn more

LION / File-Information-v0.06 / lib / File / Information / Filesystem.pm 

            

              
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
—
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126

              
# Copyright (c) 2024-2025 Löwenfelsen UG (haftungsbeschränkt)
# licensed under Artistic License 2.0 (see LICENSE file)
# ABSTRACT: generic module for extracting information from filesystems
package File::Information::Filesystem;
use v5.10;
use strict;
use warnings;
use parent 'File::Information::Base';
use Carp;
our $VERSION = v0.06;
my @_copy_properties = (
    qw(dos_device dos_path),
    qw(mountpoint fs_type),
    qw(linux_mount_options linux_superblock_options),
);
my %_properties = (
    dev_disk_by_uuid        => {rawtype => 'uuid'},
    dev_disk_by_label       => {},
    dev_name                => {},
    dev_mapper_name         => {},
    (map {$_ => {}}
        @_copy_properties,
    ),
);
my %_known_paths = (
    '/dev/disk/by-uuid'     => 'uuid',
    '/dev/disk/by-label'    => 'label',
    '/dev/mapper'           => 'mapper',
    '/dev'                  => 'dev',
);
sub _new {
    my ($pkg, %opts) = @_;
    my $self = $pkg->SUPER::_new(%opts, properties => \%_properties);
    my $pv = ($self->{properties_values} //= {})->{current} //= {};
    croak 'No stat or dirstat is given' unless defined($self->{stat}) || defined($self->{dirstat});
    croak 'No paths is given' unless defined $self->{paths};
    foreach my $key (keys %{$self->{paths}}) {
        my $known = $_known_paths{$key} or next;
        foreach my $value (@{$self->{paths}{$key}}) {
            if ($known eq 'uuid') {
                if ($value =~ __PACKAGE__->SUPER::RE_UUID) {
                    $pv->{dev_disk_by_uuid} = {raw => $value};
                }
            } elsif ($known eq 'label') {
                $pv->{dev_disk_by_label} = {raw => $value};
            } elsif ($known eq 'dev') {
                $pv->{dev_name} //= {raw => $value};
            } elsif ($known eq 'mapper') {
                $pv->{dev_mapper_name} //= {raw => $value};
            }
        }
    }
    # Simple keys:
    foreach my $key (@_copy_properties) {
        if (defined $self->{$key}) {
            $pv->{$key} = {raw => $self->{$key}};
        }
    }
    return $self;
}
# ----------------
sub _default_device_search_paths {
    return state $defaults = [qw(/dev /dev/disk/by-id /dev/mapper), keys %_known_paths];
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
File::Information::Filesystem - generic module for extracting information from filesystems
=head1 VERSION
version v0.06
=head1 SYNOPSIS
    use File::Information;
    my File::Information::Filesystem $filesystem = $instance->for_link($path)->filesystem;
    my File::Information::Filesystem $filesystem = $instance->for_handle($path)->filesystem;
B<Note:> This package inherits from L<File::Information::Base>.
This module represents a filesystem. A filesystem is the the stroage structure for inodes, hardlinks and maybe other types of objects.
=head1 METHODS
=head1 AUTHOR
Löwenfelsen UG (haftungsbeschränkt) <support@loewenfelsen.net>
=head1 COPYRIGHT AND LICENSE
This software is Copyright (c) 2024-2025 by Löwenfelsen UG (haftungsbeschränkt) <support@loewenfelsen.net>.
This is free software, licensed under:
  The Artistic License 2.0 (GPL Compatible)
=cut