File Coverage

blib/lib/Quota.pm
Criterion Covered Total %
statement 12 68 17.6
branch 0 54 0.0
condition 0 45 0.0
subroutine 4 7 57.1
pod 3 3 100.0
total 19 177 10.7


line stmt bran cond sub pod time code
1             # ------------------------------------------------------------------------ #
2             # Quota.pm - Copyright (C) 1995-2020 T. Zoerner
3             # ------------------------------------------------------------------------ #
4             # This program is free software: you can redistribute it and/or modify
5             # it either under the terms of the Perl Artistic License or the GNU
6             # General Public License as published by the Free Software Foundation.
7             # (Either version 1 of the GPL, or any later version.)
8             # For a copy of these licenses see .
9             #
10             # This program is distributed in the hope that it will be useful,
11             # but WITHOUT ANY WARRANTY; without even the implied warranty of
12             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13             # Perl Artistic License or GNU General Public License for more details.
14             # ------------------------------------------------------------------------ #
15              
16             package Quota;
17              
18             require Exporter;
19 1     1   1196 use AutoLoader;
  1         1459  
  1         6  
20             require DynaLoader;
21              
22             @ISA = qw(Exporter DynaLoader);
23             @EXPORT = ();
24              
25             $VERSION = '1.7.4';
26              
27             bootstrap Quota;
28              
29 1     1   72 use Carp;
  1         1  
  1         101  
30 1     1   560 use POSIX qw(:errno_h);
  1         8277  
  1         5  
31 1     1   1678 use strict;
  1         2  
  1         991  
32              
33             ##
34             ## Get block device for locally mounted file system
35             ## !! Do not use this to get the argument for the quota-functions in this
36             ## !! module, since not all operating systems use the device path for the
37             ## !! quotactl system call and e.g. Solaris doesn't even use a system call
38             ## !! Always use getqcarg() instead.
39             ##
40              
41             sub getdev {
42 0 0   0 1   ($#_ > 0) && croak("Usage: Quota::getdev(path)");
43 0 0         my($target) = (($#_ == -1) ? "." : $_[0]);
44 0           my($dev) = (stat($target))[0];
45 0           my($ret) = undef;
46 0           my($fsname,$path);
47            
48 0 0 0       if($dev && ($target ne "") && !Quota::setmntent()) {
      0        
49 0           while(($fsname,$path) = Quota::getmntent()) {
50 0 0         ($ret=$fsname, last) if ($dev == (stat($path))[0]);
51             }
52 0           $! = 0;
53             }
54 0           Quota::endmntent();
55 0           $ret;
56             }
57              
58             ##
59             ## Get "device" argument for this module's Quota-functions
60             ##
61              
62             sub getqcarg {
63 0 0   0 1   ($#_ > 0) && croak("Usage: Quota::getqcarg(path)");
64 0 0         my($target) = (($#_ == -1) ? "." : $_[0]);
65 0           my($dev) = (stat($target))[0];
66 0           my($ret) = undef;
67 0           my($argtyp,$fsupp) = (Quota::getqcargtype() =~ /([^,]*)(,.*)?/);
68 0           my($fsname,$path,$fstyp,$fsopt);
69              
70 0 0 0       if(defined($dev) && ($target ne "") && !Quota::setmntent()) {
      0        
71 0           while(($fsname,$path,$fstyp,$fsopt) = Quota::getmntent()) {
72 0 0         next if $fstyp =~ /^(lofs|ignore|auto.*|proc|rootfs)$/;
73 0           my($pdev) = (stat($path))[0];
74 0 0 0       if (defined($pdev) && ($dev == $pdev)) {
75 0 0 0       if ($fsname =~ m|^[^/]+:/|) {
    0          
    0          
    0          
    0          
76 0           $ret = $fsname; #NFS host:/path
77             } elsif (($fstyp =~ /^nfs/i) && ($fsname =~ m#^(/.*)\@([^/]+)$#)) {
78 0           $ret = "$2:$1"; #NFS /path@host
79             } elsif ($argtyp eq "dev") {
80 0 0         if ($fsopt =~ m#(^|,)loop=(/dev/[^,]+)#) {
81 0           $ret = $2; # Linux mount -o loop
82             } else {
83 0           $ret = $fsname;
84             }
85             } elsif ($argtyp eq "qfile") {
86 0           $ret = "$path/quotas";
87             } elsif ($argtyp eq "any") {
88 0           $ret = $target;
89             } else { #($argtyp eq "mntpt")
90 0           $ret = $path;
91             }
92              
93             # XFS, VxFS and AFS quotas require separate access methods
94             # (optional for VxFS: later versions use 'normal' quota interface)
95 0 0 0       if (($fstyp eq "xfs") && ($fsupp =~ /,XFS/)) { $ret = "(XFS)$ret" }
  0 0 0        
    0 0        
      0        
      0        
96             elsif(($fstyp eq "vxfs") &&
97 0           defined($fsupp) && ($fsupp =~ /,VXFS/)) { $ret = "(VXFS)$ret" }
98             elsif((($fstyp eq "afs") || ($fsname eq "AFS")) &&
99 0           ($fsupp =~ /,AFS/)) { $ret = "(AFS)$target"; }
100 0 0 0       if (($fstyp eq "jfs2") && ($fsupp =~ /,JFS2/)) { $ret = "(JFS2)$ret" }
  0            
101 0           last;
102             }
103             }
104 0           $! = 0;
105             }
106 0           Quota::endmntent();
107 0           $ret;
108             }
109              
110             ##
111             ## Translate error codes of quotactl syscall and ioctl
112             ##
113              
114             sub strerr {
115 0 0   0 1   ($#_ != -1) && croak("Usage: Quota::strerr()");
116 0           my($str);
117              
118 0           eval {
119 0 0 0       if(($! == &EINVAL) || ($! == &ENOTTY) || ($! == &ENOENT) || ($! == ENOSYS))
    0 0        
    0 0        
    0          
    0          
    0          
120 0           { $str = "No quotas on this system" }
121 0           elsif($! == &ENODEV) { $str = "Not a standard file system" }
122 0           elsif($! == &EPERM) { $str = "Not privileged" }
123 0           elsif($! == &EACCES) { $str = "Access denied" }
124 0           elsif($! == &ESRCH) { $str = "No quota for this user" }
125 0           elsif($! == &EUSERS) { $str = "Quota table overflow" }
126 0           else { die "unknown quota error\n" }
127             };
128 0 0         if($@) {
129 0           my($err) = $! + 0;
130 0           $str = "error #$err";
131             };
132 0           $str;
133             }
134              
135             package Quota; # return to package Quota so AutoSplit is happy
136             1;
137             __END__