package YATT::Lite::VFS;
use strict;
use warnings FATAL => qw(all);
use Exporter qw(import);
use Scalar::Util qw(weaken);
use Carp;
#========================================
# VFS 層. vfs_file (Template) のダミー実装を含む。
#========================================
{
sub MY () {__PACKAGE__}
use YATT::Lite::Types
([Item => -fields => [qw(cf_name cf_public)]
, [Folder => -fields => [qw(Item cf_path cf_parent cf_base
cf_entns)]
, -eval => q{use YATT::Lite::Util qw(cached_in);}
, [File => -fields => [qw(partlist cf_string cf_overlay)]
, -alias => 'vfs_file']
, [Dir => -fields => [qw(cf_encoding)]
, -alias => 'vfs_dir']]]);
sub YATT::Lite::VFS::Item::after_create {}
sub YATT::Lite::VFS::Folder::configure_parent {
my MY $self = shift;
# 循環参照対策
# XXX: Item に移すべきかもしれない。そうすれば、 Widget->parent が引ける。
weaken($self->{cf_parent} = shift);
}
package YATT::Lite::VFS; BEGIN {$INC{"YATT/Lite/VFS.pm"} = 1}
sub VFS () {__PACKAGE__}
use parent qw(YATT::Lite::Object);
use YATT::Lite::MFields qw/cf_ext_private cf_ext_public cf_cache cf_no_auto_create
cf_facade cf_base
cf_entns
root extdict n_creates n_updates cf_mark
pkg2folder/;
use YATT::Lite::Util qw(lexpand rootname);
sub default_ext_public {'yatt'}
sub default_ext_private {'ytmpl'}
sub new {
my ($class, $spec) = splice @_, 0, 2;
(my VFS $vfs, my @task) = $class->SUPER::just_new(@_);
foreach my $desc ([1, ($vfs->{cf_ext_public}
||= $vfs->default_ext_public)]
, [0, ($vfs->{cf_ext_private}
||= $vfs->default_ext_private)]) {
my ($value, @ext) = @$desc;
$vfs->{extdict}{$_} = $value for @ext;
}
$vfs->root_create(linsert($spec, 2, $vfs->cf_delegate(qw(entns))))
if $spec;
$$_[0]->($vfs, $$_[1]) for @task;
$vfs->after_new;
$vfs;
}
sub after_new {
my MY $self = shift;
confess __PACKAGE__ . ": facade is empty!" unless $self->{cf_facade};
weaken($self->{cf_facade});
}
sub error {
my MY $self = shift;
$self->{cf_facade}->error(@_);
}
#========================================
sub find_file {
(my VFS $vfs, my $filename) = @_;
# XXX: 拡張子をどうしたい?
my ($name) = $filename =~ m{^(\w+)}
or croak "Can't extract part name from filename '$filename'";
$vfs->{root}->lookup($vfs, $name);
}
sub list_items {
(my VFS $vfs) = @_;
$vfs->{root}->list_items($vfs);
}
#========================================
sub find_part {
my VFS $vfs = shift;
$vfs->{root}->lookup($vfs, @_);
}
sub find_part_from {
(my VFS $vfs, my $from) = splice @_, 0, 2;
my Item $item = $from->lookup($vfs, @_);
if ($item and $item->isa($vfs->Folder)) {
(my Folder $folder = $item)->{Item}{''}
} else {
$item;
}
}
# To limit call of refresh atmost 1, use this.
sub reset_refresh_mark {
(my VFS $vfs) = shift;
$vfs->{cf_mark} = @_ ? shift : {};
}
use Scalar::Util qw(refaddr);
sub YATT::Lite::VFS::File::fake_filename {
(my vfs_file $file) = @_;
$file->{cf_path} // $file->{cf_name};
}
sub YATT::Lite::VFS::File::lookup {
(my vfs_file $file, my VFS $vfs, my $name) = splice @_, 0, 3;
unless (@_) {
# ファイルの中には、深さ 1 の name しか無いはずだから。
# mtime, refresh
$file->refresh($vfs) unless $vfs->{cf_mark}{refaddr($file)}++;
my Item $item = $file->{Item}{$name};
return $item if $item;
}
# 深さが 2 以上の (name, @_) については、継承先から探す。
$file->lookup_base($vfs, $name, @_);
}
sub YATT::Lite::VFS::Dir::lookup {
(my vfs_dir $dir, my VFS $vfs, my $name) = splice @_, 0, 3;
if (my Item $item = $dir->cached_in
($dir->{Item} //= {}, $name, $vfs, $vfs->{cf_mark})) {
if (not ref $item and not $vfs->{cf_no_auto_create}) {
$item = $dir->{Item}{$name} = $vfs->create
(data => $item, parent => $dir, name => $name);
}
return $item unless @_;
$item = $item->lookup($vfs, @_);
return $item if $item;
}
$dir->lookup_base($vfs, $name, @_);
}
sub YATT::Lite::VFS::Folder::lookup_base {
(my Folder $item, my VFS $vfs, my $name) = splice @_, 0, 3;
my @super = $item->list_base;
foreach my $super (@super) {
my $ans = $super->lookup($vfs, $name, @_) or next;
return $ans;
}
undef;
}
sub YATT::Lite::VFS::Folder::list_base {
my Folder $folder = shift; @{$folder->{cf_base} ||= []}
}
sub YATT::Lite::VFS::File::list_base {
my vfs_file $file = shift;
# $dir/$file.yatt inherits its own base decl,
my @super = $file->YATT::Lite::VFS::Folder::list_base;
# $dir ($dir's bases will be called in $dir->lookup),
push @super, $file->{cf_parent} if $file->{cf_parent};
# and then directory named $dir/$file.ytmpl (or "$dir/$file")
push @super, $file->{cf_overlay} if $file->{cf_overlay};
@super;
}
sub YATT::Lite::VFS::File::list_items {
die "NIMPL";
}
sub YATT::Lite::VFS::Dir::list_items {
(my vfs_dir $in, my VFS $vfs) = @_;
return unless defined $in->{cf_path};
my %dup;
my @exts = map {
if (defined $_ and not $dup{$_}++) {
$_
} else { () }
} ($vfs->{cf_ext_public}, $vfs->{cf_ext_private});
my %dup2;
map {
my $name = substr($_, length($in->{cf_path})+1);
$name =~ s/\.\w+$//;
$dup2{$name}++ ? () : $name;
} glob("$in->{cf_path}/[a-z]*.{".join(",", @exts)."}");
}
#----------------------------------------
sub YATT::Lite::VFS::Dir::load {
(my vfs_dir $in, my VFS $vfs, my $partName) = @_;
return unless defined $in->{cf_path};
my $vfsname = "$in->{cf_path}/$partName";
my @opt = (name => $partName, parent => $in);
my ($kind, $path, @other) = do {
if (my $fn = $vfs->find_ext($vfsname, $vfs->{cf_ext_public})) {
(file => $fn, public => 1);
} elsif ($fn = $vfs->find_ext($vfsname, $vfs->{cf_ext_private})) {
# dir の場合、 new_tmplpkg では?
my $kind = -d $fn ? 'dir' : 'file';
($kind => $fn);
} elsif (-d $vfsname) {
return $vfs->{cf_facade}->create_neighbor($vfsname);
} else {
return undef;
}
};
$vfs->create($kind, $path, @opt, @other);
}
sub find_ext {
(my VFS $vfs, my ($vfsname, $spec)) = @_;
foreach my $ext (!defined $spec ? () : ref $spec ? @$spec : $spec) {
my $fn = "$vfsname.$ext";
return $fn if -e $fn;
}
}
#========================================
# 実験用、ダミーのパーサー
sub YATT::Lite::VFS::File::reset {
(my File $file) = @_;
undef $file->{partlist};
undef $file->{Item};
undef $file->{cf_string};
undef $file->{cf_base};
}
sub YATT::Lite::VFS::Dir::refresh {}
sub YATT::Lite::VFS::File::refresh {
(my vfs_file $file, my VFS $vfs) = @_;
return unless $$file{cf_path} || $$file{cf_string};
# XXX: mtime!
$vfs->{n_updates}++;
my @part = do {
local $/; split /^!\s*(\w+)\s+(\S+)[^\n]*?\n/m, do {
if ($$file{cf_path}) {
open my $fh, '<', $$file{cf_path}
or die "Can't open '$$file{cf_path}': $!";
scalar <$fh>
} else {
$$file{cf_string};
}
};
};
$file->add_widget('', shift @part);
while (my ($kind, $name, $part) = splice @part, 0, 3) {
if (defined $kind and my $sub = $file->can("declare_$kind")) {
$sub->($file, $name, $vfs, $part);
} else {
$file->can("add_$kind")->($file, $name, $part);
}
}
}
#========================================
sub add_to {
(my VFS $vfs, my ($path, $data)) = @_;
my @path = ref $path ? @$path : $path;
my $lastName = pop @path;
my Folder $folder = $vfs->{root};
while (@path) {
my $name = shift @path;
$folder = $folder->{Item}{$name} ||= $vfs->create
(data => {}, name => $name, parent => $folder);
}
# XXX: path を足すと、memory 動作の時に困る
$folder->{Item}{$lastName} = $vfs->create
(data => $data, name => $lastName, parent => $folder);
}
#========================================
sub root {(my VFS $vfs) = @_; $vfs->{root}}
# special hook for root creation.
sub root_create {
(my VFS $vfs, my ($kind, $primary, %rest)) = @_;
$rest{entns} //= $vfs->{cf_entns};
$vfs->{root} = $vfs->create($kind, $primary, %rest);
}
sub create {
(my VFS $vfs, my ($kind, $primary, %rest)) = @_;
# XXX: $vfs は className の時も有る。
if (my $sub = $vfs->can("create_$kind")) {
$vfs->fixup_created($sub->($vfs, $primary, %rest));
} else {
$vfs->{cf_cache}{$primary} ||= do {
# XXX: Really??
$rest{entns} //= $vfs->{cf_entns};
$vfs->fixup_created
($vfs->can("vfs_$kind")->()->new(%rest, path => $primary));
};
}
}
sub fixup_created {
(my VFS $vfs, my Folder $folder) = @_;
# create の直後、 after_create より前に、mark を打つ。そうしないと、 delegate で困る。
if (ref $vfs) {
$vfs->{n_creates}++;
$vfs->{cf_mark}{refaddr($folder)}++;
}
if (my Folder $parent = $folder->{cf_parent}) {
if (defined $parent->{cf_entns}) {
$folder->{cf_entns} = join '::'
, $parent->{cf_entns}, $folder->{cf_name};
# XXX: base 指定だけで済むべきだが、Factory を呼んでないので出来ないorz...
YATT::Lite::MFields->add_isa_to
($folder->{cf_entns}, $parent->{cf_entns});
$vfs->{pkg2folder}{$folder->{cf_entns}} = $folder;
}
}
$folder->after_create($vfs);
$folder;
}
sub create_data {
(my VFS $vfs, my ($primary)) = splice @_, 0, 2;
if (ref $primary) {
# 直接 Folder slot にデータを。
my vfs_dir $item = $vfs->vfs_dir->new(@_);
$item->{Item} = $primary;
$item;
} else {
$vfs->vfs_file->new(public => 1, @_, string => $primary);
}
}
sub YATT::Lite::VFS::Dir::after_create {
(my vfs_dir $dir, my VFS $vfs) = @_;
foreach my Folder $desc (@{$dir->{cf_base}}) {
$desc = $vfs->create(@$desc) if ref $desc eq 'ARRAY';
# parent がある == parent から指されている。なので、 weaken する必要が有る。
weaken($desc) if $desc->{cf_parent};
}
# $dir->refresh($vfs);
$dir;
}
# file 系は create 時に必ず refresh. refresh は decl のみ parse.
sub YATT::Lite::VFS::File::after_create {
(my vfs_file $file, my VFS $vfs) = @_;
$file->refresh_overlay($vfs);
$file->refresh($vfs);
}
sub YATT::Lite::VFS::File::refresh_overlay {
(my vfs_file $file, my VFS $vfs) = @_;
return if $file->{cf_overlay};
return unless $file->{cf_path};
my $rootname = rootname($file->{cf_path});
my @found = grep {-d $$_[-1]} ([1, $rootname]
, [0, "$rootname.$vfs->{cf_ext_private}"]);
if (@found > 1) {
$vfs->error(q|Don't use %1$s and %1$s.%2$s at once|
, $rootname, $vfs->{cf_ext_private});
} elsif (not @found) {
return;
}
$file->{cf_overlay} = do {
my ($public, $path) = @{$found[0]};
if ($public) {
$vfs->{cf_facade}->create_neighbor($path);
} else {
$vfs->create
(dir => $path, parent => $file->{cf_parent});
}
};
}
#----------------------------------------
sub YATT::Lite::VFS::File::declare_base {
(my vfs_file $file, my ($spec), my VFS $vfs, my $part) = @_;
my ($kind, $path) = split /=/, $spec, 2;
# XXX: 物理 path だと困るよね? findINC 的な処理が欲しい
# XXX: 帰属ディレクトリより強くするため、先頭に。でも、不満。
unshift @{$file->{cf_base}}, $vfs->create($kind => $path);
weaken($file->{cf_base}[0]);
$file->{Item}{''} .= $part;
}
sub YATT::Lite::VFS::File::add_widget {
(my vfs_file $file, my ($name, $part)) = @_;
push @{$file->{partlist}}, $file->{Item}{$name} = $part;
}
sub linsert {
my @ls = @{shift()};
splice @ls, shift, 0, @_;
wantarray ? @ls : \@ls;
}
}
use YATT::Lite::Breakpoint;
YATT::Lite::Breakpoint::break_load_vfs();
1;