#!/usr/bin/env perl
+# fioc.pl: A Perl conversion of the fioc example IOCTL server program
+# from the FUSE distribution. I've endeavored to stay pretty close
+# structure-wise to the C version, while using Perl-specific features.
+# I wrote this to provide a way to verify my ioctl() wrapper
+# implementation would work properly. So far, it seems to, and it will
+# interoperate with the C client as well.
+
use strict;
no strict qw(refs);
-use Carp ();
+use threads;
+use threads::shared;
+
+use Carp;
local $SIG{'__WARN__'} = \&Carp::cluck;
-use Fuse;
+use Fuse qw(:all);
use Fcntl qw(:mode);
-use Errno qw(:POSIX);
use POSIX;
-my $fioc_size = 0;
+my $fioc_size :shared = 0;
use constant FIOC_NAME => 'fioc';
-my $fioc_buf = '';
+my $fioc_buf :shared = '';
use constant FIOC_NONE => 0;
use constant FIOC_ROOT => 1;
use constant FIOC_FILE => 2;
-sub _IOC_NRBITS { 8 }
-sub _IOC_NRMASK { ( 1 << &_IOC_NRBITS ) - 1 }
-sub _IOC_NRSHIFT { 0 }
-
-sub _IOC_TYPEBITS { 8 }
-sub _IOC_TYPEMASK { ( 1 << &_IOC_TYPEBITS ) - 1 }
-sub _IOC_TYPESHIFT { &_IOC_NRSHIFT + &_IOC_NRBITS }
-
-sub _IOC_SIZEBITS { ( POSIX::uname() )[4] =~ /^i[3-6]86|x86_64$/ ? 14 : 13 }
-sub _IOC_SIZEMASK { ( 1 << &_IOC_SIZEBITS ) - 1 }
-sub _IOC_SIZESHIFT { &_IOC_TYPESHIFT + &_IOC_TYPEBITS }
-
-sub _IOC_DIRBITS { 32 - &_IOC_NRBITS - &_IOC_TYPEBITS - &_IOC_SIZEBITS }
-sub _IOC_DIRMASK { ( 1 << &_IOC_DIRBITS ) - 1 }
-sub _IOC_DIRSHIFT { &_IOC_SIZESHIFT + &_IOC_SIZEBITS }
-
-sub _IOC_NONE { ( POSIX::uname() )[4] =~ /^i[3-6]86|x86_64$/ ? 0 : 1 }
-sub _IOC_WRITE { ( POSIX::uname() )[4] =~ /^i[3-6]86|x86_64$/ ? 1 : 4 }
-sub _IOC_READ { ( POSIX::uname() )[4] =~ /^i[3-6]86|x86_64$/ ? 2 : 2 }
-
-sub _IOC ($$$$) {
- ( $_[0] << &_IOC_DIRSHIFT ) | ( ord( $_[1] ) << &_IOC_TYPESHIFT ) |
- ( $_[2] << &_IOC_NRSHIFT ) | ( $_[3] << &_IOC_SIZESHIFT );
-}
-
-sub _IO ($$) { &_IOC( &_IOC_NONE, $_[0], $_[1], 0 ) }
-sub _IOR ($$$) { &_IOC( &_IOC_READ, $_[0], $_[1], $_[2] ) }
-sub _IOW ($$$) { &_IOC( &_IOC_WRITE, $_[0], $_[1], $_[2] ) }
-sub _IOWR ($$$) { &_IOC( &_IOC_READ | &_IOC_WRITE, $_[0], $_[1], $_[2] ) }
+require 'asm/ioctl.ph';
-sub FIOC_GET_SIZE { _IOR('E', 0, 4); }
-sub FIOC_SET_SIZE { _IOW('E', 1, 4); }
+our %sizeof = ('size_t' => length(pack('L!')));
+sub FIOC_GET_SIZE { _IOR(ord 'E', 0, 'size_t'); }
+sub FIOC_SET_SIZE { _IOW(ord 'E', 1, 'size_t'); }
+sub TCGETS { 0x5401; }
sub fioc_resize {
my ($size) = @_;
print 'called ', (caller(0))[3], "\n";
return 0 if $size == $fioc_size;
-
+
if ($size < $fioc_size) {
$fioc_buf = substr($fioc_buf, 0, $size);
}
my ($path, $flags, $info) = @_;
print 'called ', (caller(0))[3], "\n";
- if (fioc_file_type($path) != FIOC_NONE) {
- return 0;
- }
+ return 0 if fioc_file_type($path) != FIOC_NONE;
return -&ENOENT;
}
print 'called ', (caller(0))[3], "\n";
return -&EINVAL if fioc_file_type($path) != FIOC_FILE;
-
- if ($offset > $fioc_size) {
- return q{};
- }
+ return q{} if $offset > $fioc_size;
if ($size > $fioc_size - $offset) {
$size - $fioc_size - $offset;
sub fioc_write {
my ($path, $data, $offset) = @_;
print 'called ', (caller(0))[3], "\n";
+ lock($fioc_buf);
return -&EINVAL if fioc_file_type($path) != FIOC_FILE;
-
- if (fioc_expand($offset + length($data))) {
- return -&ENOMEM;
- }
+ return -&ENOMEM if fioc_expand($offset + length($data));
substr($fioc_buf, $offset, length($data), $data);
return length($data);
sub fioc_truncate {
my ($path, $size) = @_;
print 'called ', (caller(0))[3], "\n";
+ lock($fioc_buf);
return -&EINVAL if fioc_file_type($path) != FIOC_FILE;
sub fioc_ioctl {
my ($path, $cmd, $flags, $data) = @_;
print 'called ', (caller(0))[3], "\n";
- $cmd = unpack('L', pack('l', $cmd));
- print("fioc_ioctl(): path is \"$path\", cmd is $cmd, flags is $flags\n");
return -&EINVAL if fioc_file_type($path) != FIOC_FILE;
-
- return -&ENOSYS if $flags & 0x1;
+ return -&ENOSYS if $flags & FUSE_IOCTL_COMPAT;
if ($cmd == FIOC_GET_SIZE) {
- print "handling FIOC_GET_SIZE\n";
- return(0, pack('L', $fioc_size));
+ return(0, pack('L!', $fioc_size));
}
elsif ($cmd == FIOC_SET_SIZE) {
- print "handling FIOC_SET_SIZE\n";
- fioc_resize(unpack('L', $data));
+ lock($fioc_buf);
+ fioc_resize(unpack('L!', $data));
return 0;
}
+ elsif ($cmd == TCGETS) {
+ # perl sends TCGETS as part of calling isatty() on opening a file;
+ # this appears to be a more canonical answer
+ return -&ENOTTY;
+ }
return -&EINVAL;
}
'open' => 'main::fioc_open',
'read' => 'main::fioc_read',
'write' => 'main::fioc_write',
- 'ioctl' => 'main::fioc_ioctl');
+ 'ioctl' => 'main::fioc_ioctl',
+ 'threaded' => 1);