|. By the way, I highly recommend using the HTML view of Perl objects while reading the rest of this guide. You can get to them here: \url{http://spencertipping.com/perl-objects} (each {\tt .html} file is just a symlink to the Perl object of the same name). __ meta::section('serialization', <<'__'); - sc Serialization | sec:serialization Earlier I alluded to a glaring problem with these scripts as they stand. The issue is the {\tt EOF} marker we've been using. Here's what happens if we put a line containing {\tt EOF} into an attribute: - verbatim << end $ cp examples/basic-meta-with-functions temp $ perl temp set function::bif print <<'EOF'; uh-oh... EOF ^D $ perl temp cat function::bif Can't locate object method "EOF" via package "meta::function" at temp line 31. $ - end It's not hard to see what went wrong: {\tt temp} now has an attribute definition that looks like this: - verbatim << end meta::function('bif', <<'EOF'); print <<'EOF'; uh-oh... EOF EOF - end We need to come up with some end marker that isn't in the value being stored. For the moment let's use random numbers.\footnote{{\tt object} implements a simple FNV-hash and uses the hash of the contents. I'll go over how to implement this a bit later.} - s1 Fixing the {\tt EOF} markers | sec:serialization-fixing-the-eof-markers There isn't a particularly compelling reason to inline the serialization logic in {\tt code::main}. Since we have a low-overhead way of defining functions, let's make a {\tt serialize} function to return the state of a script as a string, along with a helper method \verb|serialize_single| to handle one attribute at a time: - perl snippets/serialize-and-serialize-single << end meta::function('serialize', <<'EOF'); my @keys = sort keys %data; join "\n", $data{'bootstrap::initialization'}, map(serialize_single($_), grep !/^code::/, @keys), map(serialize_single($_), grep /^code::/, @keys), "\n__END__"; EOF meta::function('serialize_single', <<'EOF'); my ($namespace, $name) = split /::/, $_[0], 2; my $marker = '__' . int(rand(1 << 31)); "meta::$namespace('$name', <<'$marker');\n$data{$_[0]}\n$marker"; EOF - end Sorting the keys is important. We'll be verifying the output of the serialization function, so it needs to be stable. Now {\tt code::main} is a bit simpler. With these new functions the file logic becomes: - verbatim << end open my $file, '>', $0; print $file serialize(); close $file; - end - s1 Verifying serialization | sec:serialization-verifying-serialization What we've been doing is very unsafe. There isn't a backup file, so if the serialization goes wrong then we'll blindly nuke our original script. This is a big problem, so let's fix it. The new strategy will be to serialize to a temporary file, have that file generate a checksum, and make sure that the checksum is what we expect. Before we can implement such a mechanism, though, we'll need a string hash function. - s2 Implementing the Fowler-Noll Vo hash | sec:serialization-verifying-fnv-hash At its core, the FNV-1a hash\footnote{\url{http://en.wikipedia.org/wiki/Fowler-Noll-Vo_hash_function}} is just a multiply-xor in a loop. Generally it's written like this: - cpp snippets/fnv-hash.c << end int hash (char *s) { const int fnv_prime = 16777619; // Magic numbers const int fnv_offset = 2166136261; int result = fnv_offset; char c; while (c = *s++) { result ^= c; result *= fnv_prime; } return result; } - end In Perl it's advantageous to vectorize this function for performance reasons. It isn't necessarily sound to do this, but empirically the results seem reasonably well-distributed. Here's the function I ended up with: - perl snippets/fnv-hash-function << end meta::function('fnv_hash', <<'EOF'); my ($data) = @_; my ($fnv_prime, $fnv_offset) = (16777619, 2166136261); my $hash = $fnv_offset; my $modulus = 2 ** 32; $hash = ($hash ^ ($_ & 0xffff) ^ ($_ >> 16)) * $fnv_prime % $modulus for unpack 'L*', $data . substr($data, -4) x 8; $hash; EOF - end This produces a 32-bit hash. Ideally we have something of at least 128 bits, just to reduce the likelihood of collision. When I was writing the 128-bit hash I went a bit overboard with hash chaining (which doesn't matter because it isn't a cryptographic hash), but here's the full hash: - perl snippets/fast-hash-function << end meta::function('fast_hash', <<'EOF'); my ($data) = @_; my $piece_size = length($data) >> 3; my @pieces = (substr($data, $piece_size * 8) . length($data), map(substr($data, $piece_size * $_, $piece_size), 0 .. 7)); my @hashes = (fnv_hash($pieces[0])); push @hashes, fnv_hash($pieces[$_ + 1] . $hashes[$_]) for 0 .. 7; $hashes[$_] ^= $hashes[$_ + 4] >> 16 | ($hashes[$_ + 4] & 0xffff) << 16 for 0 .. 3; $hashes[0] ^= $hashes[8]; sprintf '%08x' x 4, @hashes[0 .. 3]; EOF - end The convolutedness of this logic is partially to accommodate for very short strings. - s2 Fixing {\tt EOF} markers again | sec:serialization-verifying-fixing-eof-markers-again It's probably fine to use random numbers for EOF markers, but I prefer using a hash of the content. While it's probably about the same either way, it intuitively feels less likely that a string will contain its own hash.\footnote{And as we all know, intuition is key when making decisions in math and computer science...} - perl snippets/serialize-single-hash << end meta::function('serialize_single', <<'EOF'); my ($namespace, $name) = split /::/, $_[0], 2; my $marker = '__' . fast_hash($data{$_[0]}); "meta::$namespace('$name', <<'$marker');\n$data{$_[0]}\n$marker"; EOF - end We can also use the script state to get a tempfile in the {\tt edit} function.\footnote{{\tt object} uses {\tt File::Temp} to get temporary filenames. This is a better solution than anything involving pseudorandom names in {\tt /tmp}.} - s2 Implementing the {\tt state} function | sec:serialization-verifying-state-function The ``state'' of an object is just the hash of its serialization. (This is why it's useful to have the serialization logic factored out.) - perl snippets/state-function-hash << end meta::function('state', <<'EOF'); fast_hash(serialize()); EOF - end - s2 Implementing the {\tt verify} function | sec:serialization-verifying-verify-function {\tt verify} writes a temporary copy, checks its checksum, and returns {\tt 0} or {\tt 1} depending on whether the checksum came out invalid or valid, respectively. If invalid, it leaves the temporary file there for debugging purposes. - perl snippets/verify-function << end meta::function('verify', <<'EOF'); my $serialized_data = serialize(); my $state = state(); my $temporary_filename = "$0.$state"; open my $file, '>', $temporary_filename; print $file $serialized_data; close $file; chmod 0700, $temporary_filename; chomp(my $observed_state = join '', qx|perl '$temporary_filename' state|); my $result = $observed_state eq $state; unlink $temporary_filename if $result; $result; EOF - end - s1 Save logic | sec:serialization-save-logic Now we can use {\tt verify} before overwriting \verb|$0|. - perl snippets/save-function-and-broken-usage << end meta::function('save', <<'EOF'); if (verify()) { open my $file, '>', $0; print $file serialize(); close $file; } else { warn 'Verification failed'; } EOF meta::code('main', <<'EOF'); ... save(); EOF - end - s1 {\tt code::main} fixes | sec:serialization-code-main-fixes There's actually a fairly serious problem at this point. Every script saves itself unconditionally, which involves creating a temporary filename and verifying its contents. What happens when we run one then? Something like this: - verbatim << end $ perl some-script cat function::cat join "\n", @data{@_}; # Gets this much right # Now calls save(), which calls verify() to create a new temp script: > perl some-script.hash1 state hash1 # Gets this much right # Now calls save(), which calls verify() to create a new temp script: > perl some-script.hash1.hash2 state ... - end That's not what we want at all. There's no reason to call {\tt save} unless a modification has occurred, so we can make this modification to {\tt code::main}: - perl snippets/code-main-with-fixed-save << end meta::code('main', <<'EOF'); my $initial_state = state(); my $command = shift @ARGV; print &$command(@ARGV); # Also printing the result -- important for state save() if state() ne $initial_state; EOF - end - s1 Final result | sec:serialization-final-result At this point we have an extensible and reasonably robust script. Here's what we've got so far: - perl examples/verified << end my %data; my %datatypes; sub meta::define_form { my ($namespace, $delegate) = @_; $datatypes{$namespace} = $delegate; *{"meta::${namespace}::implementation"} = $delegate; *{"meta::$namespace"} = sub { my ($name, $value) = @_; chomp $value; $data{"${namespace}::$name"} = $value; $delegate->($name, $value); }; } meta::define_form 'bootstrap', sub {}; meta::define_form 'function', sub { my ($name, $body) = @_; *{$name} = eval "sub {\n$body\n}"; }; meta::define_form 'code', sub { my ($name, $value) = @_; eval $value; }; meta::bootstrap('initialization', <<'EOF'); my %data; my %datatypes; sub meta::define_form { my ($namespace, $delegate) = @_; $datatypes{$namespace} = $delegate; *{"meta::${namespace}::implementation"} = $delegate; *{"meta::$namespace"} = sub { my ($name, $value) = @_; chomp $value; $data{"${namespace}::$name"} = $value; $delegate->($name, $value); }; } meta::define_form 'bootstrap', sub {}; meta::define_form 'function', sub { my ($name, $body) = @_; *{$name} = eval "sub {\n$body\n}"; }; meta::define_form 'code', sub { my ($name, $value) = @_; eval $value; }; EOF meta::function('serialize', <<'EOF'); my @keys = sort keys %data; join "\n", $data{'bootstrap::initialization'}, map(serialize_single($_), grep !/^code::/, @keys), map(serialize_single($_), grep /^code::/, @keys), "\n__END__"; EOF meta::function('serialize_single', <<'EOF'); my ($namespace, $name) = split /::/, $_[0], 2; my $marker = '__' . fast_hash($data{$_[0]}); "meta::$namespace('$name', <<'$marker');\n$data{$_[0]}\n$marker"; EOF meta::function('fnv_hash', <<'EOF'); my ($data) = @_; my ($fnv_prime, $fnv_offset) = (16777619, 2166136261); my $hash = $fnv_offset; my $modulus = 2 ** 32; $hash = ($hash ^ ($_ & 0xffff) ^ ($_ >> 16)) * $fnv_prime % $modulus for unpack 'L*', $data . substr($data, -4) x 8; $hash; EOF meta::function('fast_hash', <<'EOF'); my ($data) = @_; my $piece_size = length($data) >> 3; my @pieces = (substr($data, $piece_size * 8) . length($data), map(substr($data, $piece_size * $_, $piece_size), 0 .. 7)); my @hashes = (fnv_hash($pieces[0])); push @hashes, fnv_hash($pieces[$_ + 1] . $hashes[$_]) for 0 .. 7; $hashes[$_] ^= $hashes[$_ + 4] >> 16 | ($hashes[$_ + 4] & 0xffff) << 16 for 0 .. 3; $hashes[0] ^= $hashes[8]; sprintf '%08x' x 4, @hashes[0 .. 3]; EOF meta::function('state', <<'EOF'); fast_hash(serialize()); EOF meta::function('verify', <<'EOF'); my $serialized_data = serialize(); my $state = state(); my $temporary_filename = "$0.$state"; open my $file, '>', $temporary_filename; print $file $serialized_data; close $file; chmod 0700, $temporary_filename; chomp(my $observed_state = join '', qx|perl '$temporary_filename' state|); my $result = $observed_state eq $state; unlink $temporary_filename if $result; $result; EOF meta::function('save', <<'EOF'); if (verify()) { open my $file, '>', $0; print $file serialize(); close $file; } else { warn 'Verification failed'; } EOF meta::function('cat', <<'EOF'); join "\n", @data{@_}; EOF meta::function('set', <<'EOF'); $data{$_[0]} = join '', ; EOF meta::function('edit', <<'EOF'); my $filename = '/tmp/' . rand(); open my $file, '>', $filename; print $file $data{$_[0]}; close $file; system($ENV{EDITOR} || $ENV{VISUAL} || '/usr/bin/nano', $filename); open my $file, '<', $filename; $data{$_[0]} = join '', <$file>; close $file; EOF meta::code('main', <<'EOF'); my $initial_state = state(); my $command = shift @ARGV; print &$command(@ARGV); save() if state() ne $initial_state; EOF __END__ - end __ meta::section('some-improvements', <<'__'); - sc Some improvements | sec:some-improvements Let's step back for a minute and improve things a bit in preparation for some real awesomeness. There are few places that could use improvement. First, there isn't a way to get a list of defined attributes on an object without opening it by hand. Second, the interface exposes too many functions to the user; in particular, things like {\tt complete} aren't useful from the command line. Finally, every data type we define gets put into {\tt bootstrap::initialization}, which causes $O(n)$ redundancy in the size of the data type constructors. - s1 Useful functions | sec:some-improvements-useful-functions The most important thing to add is {\tt ls}, which gives you a listing of attributes:\footnote{{\tt object} contains a much more sophisticated version of {\tt ls}. It parses options and applies filters to the listing, much like the UNIX {\tt ls} command. I'll go over how to implement this stuff in a later chapter.} Related are {\tt cp} and {\tt rm}, which do what you would expect: - perl snippets/ls-cp-and-rm-functions << end meta::function('ls', <<'EOF'); join "\n", sort keys %data; EOF meta::function('cp', <<'EOF'); $data{$_[1]} = $data{$_[0]}; EOF meta::function('rm', <<'EOF'); delete @data{@_}; EOF - end Another useful function is {\tt create}, which opens an editor for a new attribute:\footnote{We can already do this with {\tt edit}, but {\tt object} doesn't let you edit attributes that don't exist. I'll include that behavior in these scripts before too long.} - perl snippets/create-function << end meta::function('create', <<'EOF'); return edit($_[0]) if exists $data{$_[0]}; $data{$_[0]} = $_[1] || "# Attribute $_[0]"; edit($_[0]); EOF - end Now we can create stuff from inside the shell or command-line and have a civilized text-editor interface to do it. - s1 Making some functions internal | sec:some-improvements-making-some-functions-internal It would be nice to have a distinction between functions meant for public consumption and functions used just inside the script. For example, nobody's going to call \verb|fnv_hash| from the command-line; they'd have to pass it a string in {\tt @ARGV}, which isn't practical. So it's time for a new toplevel mechanism, the \verb|%externalized_functions| table: - verbatim << end # In bootstrap::initialization: my %data; my %externalized_functions; my %datatypes; - end \verb|%externalized_functions| maps every callable function to the attribute that defines it, and only the listed functions will be usable directly from the shell or the command-line. This has an additional benefit of providing much better autocompletion, since the first word in the REPL always names a function. - verbatim << end meta::define_form 'data', sub { my ($name, $value) = @_; $externalized_functions{$name} = "data::$name"; *{$name} = ...; }; meta::define_form 'function', sub { my ($name, $value) = @_; $externalized_functions{$name} = "function::$name"; *{$name} = ...; }; - end \noindent And here's the new data type: - perl snippets/internal-function-type << end meta::define_form 'internal_function', sub { my ($name, $value) = @_; *{$name} = eval "sub {\n$value\n}"; }; - end We can now move \verb|fnv_hash|, \verb|fast_hash|, and {\tt complete} into this namespace. We'll need to update {\tt shell} and {\tt complete} to leverage this new information: - perl snippets/shell-2 << end meta::function('shell', <<'EOF'); use Term::ReadLine; my $term = new Term::ReadLine "$0 shell"; $term->ornaments(0); my $output = $term->OUT || \*STDOUT; $term->Attribs->{attempted_completion_function} = \&complete; while (defined($_ = $term->readline("$0\$ "))) { my @args = grep length, split /\s+|("[^"\\]*(?:\\.)?")/o; my $function_name = shift @args; s/^"(.*)"$/\1/o, s/\\\\"/"/go for @args; if ($function_name) { if ($externalized_functions{$function_name}) { chomp(my $result = eval {&$function_name(@args)}); warn $@ if $@; print $output $result, "\n" unless $@; } else { warn "Command not found: '$function_name' (use 'ls' to see available commands)"; } } } EOF - end - perl snippets/complete-2 << end meta::function('complete', <<'EOF'); my @functions = sort keys %externalized_functions; my @attributes = sort keys %data; sub match { my ($text, @options) = @_; my @matches = sort grep /^$text/, @options; if (@matches == 0) {return undef;} elsif (@matches == 1) {return $matches [0];} elsif (@matches > 1) { return ((longest ($matches [0], $matches [@matches - 1])), @matches); } } sub longest { my ($s1, $s2) = @_; return substr ($s1, 0, length $1) if ($s1 ^ $s2) =~ /^(\0*)/; return ''; } my ($text, $line) = @_; if ($line =~ / /) { # Start matching attribute names. match ($text, @attributes); } else { # Start of line, so it's a function. match ($text, @functions); } EOF - end - s1 Separate attributes for data types | sec:some-improvements-separate-attributes-for-data-types It's cumbersome to have all of the data types go in {\tt bootstrap::initialization}. Better is to break the code into separate attributes. To do this we'll need to restructure the scripts a little bit. Up until now the ``stuff first, code second'' approach has worked out all right. But now we want to evaluate stuff at the beginning and at the end, and if this keeps up it could get out of hand. Better is to have {\tt serialize} generate a call into some function that will be defined, and do away with {\tt code::} altogether. We can use a new namespace {\tt meta::} for stuff that needs to be evaluated at the beginning. So basically, instead of this: - verbatim << end bootstrap types functions code - end \noindent we'd have this: - verbatim << end bootstrap meta definitions functions call to internal::main() - end Here's what the new {\tt serialize} looks like: - perl snippets/serialize-with-internal-main << end my @keys = sort keys %data; join "\n", $data{'bootstrap::initialization'}, map(serialize_single($_), grep( /^meta::/, @keys), grep(!/^meta::/, @keys)), "internal::main();", "__END__"; - end And here's the definition for {\tt meta::} (it's identical to the one we used to have for {\tt code::}). This is the only \verb|define_form| invocation in {\tt bootstrap::initialization}; the others now reside in their own attributes. - perl snippets/define-form-meta << end meta::define_form 'meta', sub { my ($name, $value) = @_; eval $value; }; - end Here are the new type definitions: - verbatim << end meta::meta('type::data', <<'EOF'); meta::define_form 'data', sub {...}; EOF meta::meta('type::function', <<'EOF'); meta::define_form 'function', sub {...}; EOF meta::meta('type::bootstrap', <<'EOF'); meta::define_form 'bootstrap', sub {}; EOF ... - end - s2 Factoring externalization | sec:some-improvements-data-types-factoring-externalization While we're cleaning up meta-stuff, it's worth thinking about factoring out externalization. There isn't a particularly good reason to keep manually assigning to \verb|%externalized_functions|; better is to abstract this detail into a function. To do this, we'll want a meta-library: - perl snippets/meta-externalize << end meta::meta('externalize', <<'EOF'); sub meta::externalize { my ($name, $attribute, $implementation) = @_; $externalized_functions{$name} = $attribute; *{$name} = $implementation; } EOF - end This meta-definition is available to the others because it sorts first.\footnote{Which is a horrible way to manage dependencies, but it's worked so far.} Now instead of manually externalizing stuff, data types like {\tt function::} and {\tt data::} can just use {\tt meta::externalize}: - perl snippets/function-type-with-externalize << end meta::meta('type::function', <<'EOF'); meta::define_form 'function', sub { my ($name, $value) = @_; meta::externalize $name, "function::$name", eval "sub {\n$value\n}"; }; EOF - end - s1 Abstracting {\tt \%data} | sec:some-improvements-abstracting-data Another issue worth fixing is that you can assign into \verb|%data| arbitrarily, particularly in ways that end up breaking deserialization. For instance, nothing is stopping you from creating a key called {\tt foo::bar} even though there isn't a namespace called {\tt foo::}. This problem can be solved at the interface level (i.e.~inside {\tt edit}, {\tt set}, and such), but it's probably more useful to go a step further and abstract all access to \verb|%data|. Rather than writing to \verb|%data|, then, we'll use an internal function called {\tt associate}; and to read from it we'll use {\tt retrieve}. These two functions also benefit from a couple more to separate out namespace components. The {\tt namespace} function gives you the base part, and the {\tt attribute} function gives you the rest.\footnote{All four of these functions are taken directly from {\tt object}.} - perl snippets/namespace-attribute-retrieve-associate-functions << end meta::internal_function('namespace', <<'EOF'); my ($name) = @_; $name =~ s/::.*$//; $name; EOF meta::internal_function('attribute', <<'EOF'); my ($name) = @_; $name =~ s/^[^:]*:://; $name; EOF meta::internal_function('retrieve', <<'EOF'); my @results = map defined $data{$_} ? $data{$_} : file::read($_), @_; wantarray ? @results : $results[0]; EOF meta::internal_function('associate', <<'EOF'); my ($name, $value, %options) = @_; my $namespace = namespace($name); die "Namespace $namespace does not exist" unless $datatypes{$namespace}; $data{$name} = $value; execute($name) if $options{'execute'}; EOF - end - s2 Dynamic execution | sec:some-improvements-abstracting-data-dynamic-execution One problem with the way we've defined {\tt cp} is that you'll have to close and reopen the shell to get new functions to take effect. This is because while we're assigning into \verb|%data|, we're not calling the handler associated with the namespace. The simplest way to fix this is to dynamically invoke that handler: - perl snippets/execute-function << end meta::internal_function('execute', <<'EOF'); my ($name, %options) = @_; my $namespace = namespace($name); eval {&{"meta::$namespace"}(attribute($name), retrieve($name))}; warn $@ if $@ && $options{'carp'}; EOF - end {\tt associate} is already hooked up to use this function; all you have to do is pass an extra option: - verbatim << end associate('function::foo', '...', execute => 1); - end - s1 Final result | sec:some-improvements-final-result Integrating all of these improvements into the previous chapter's script yields this monumental piece of work:\footnote{This is the last full listing I'll provide here. The remaining chapters cover the concepts required to get from here to {\tt object}. At this point the stuff going on in {\tt object} should more or less make sense, though you'll want to use {\tt ls-a} rather than {\tt ls} to get a full listing of attributes.} - perl examples/some-improvements << end #!/usr/bin/perl my %data; my %externalized_functions; my %datatypes; sub meta::define_form { my ($namespace, $delegate) = @_; $datatypes{$namespace} = $delegate; *{"meta::${namespace}::implementation"} = $delegate; *{"meta::$namespace"} = sub { my ($name, $value) = @_; chomp $value; $data{"${namespace}::$name"} = $value; $delegate->($name, $value); }; } meta::define_form 'meta', sub { my ($name, $value) = @_; eval $value; }; meta::meta('externalize', <<'EOF'); sub meta::externalize { my ($name, $attribute, $implementation) = @_; $externalized_functions{$name} = $attribute; *{$name} = $implementation; } EOF meta::meta('type::bootstrap', <<'EOF'); meta::define_form 'bootstrap', sub {}; EOF meta::meta('type::function', <<'EOF'); meta::define_form 'function', sub { my ($name, $body) = @_; meta::externalize $name, "function::$name", eval "sub {\n$body\n}"; }; EOF meta::meta('type::internal_function', <<'EOF'); meta::define_form 'internal_function', sub { my ($name, $value) = @_; *{$name} = eval "sub {\n$value\n}"; }; EOF meta::meta('type::data', <<'EOF'); meta::define_form 'data', sub { # Define a basic editing interface: my ($name, $value) = @_; meta::externalize $name, "data::$name", sub { my ($command, $value) = @_; return $data{"data::$name"} unless @_; $data{"data::$name"} = $value if $command eq '='; }; }; EOF meta::bootstrap('initialization', <<'EOF'); #!/usr/bin/perl my %data; my %externalized_functions; my %datatypes; sub meta::define_form { my ($namespace, $delegate) = @_; $datatypes{$namespace} = $delegate; *{"meta::${namespace}::implementation"} = $delegate; *{"meta::$namespace"} = sub { my ($name, $value) = @_; chomp $value; $data{"${namespace}::$name"} = $value; $delegate->($name, $value); }; } meta::define_form 'meta', sub { my ($name, $value) = @_; eval $value; }; EOF meta::data('default-action', <<'EOF'); shell EOF meta::internal_function('namespace', <<'EOF'); my ($name) = @_; $name =~ s/::.*$//; $name; EOF meta::internal_function('attribute', <<'EOF'); my ($name) = @_; $name =~ s/^[^:]*:://; $name; EOF meta::internal_function('retrieve', <<'EOF'); my @results = map defined $data{$_} ? $data{$_} : file::read($_), @_; wantarray ? @results : $results[0]; EOF meta::internal_function('associate', <<'EOF'); my ($name, $value, %options) = @_; my $namespace = namespace($name); die "Namespace $namespace does not exist" unless $datatypes{$namespace}; $data{$name} = $value; execute($name) if $options{'execute'}; EOF meta::internal_function('execute', <<'EOF'); my ($name, %options) = @_; my $namespace = namespace($name); eval {&{"meta::$namespace"}(attribute($name), retrieve($name))}; warn $@ if $@ && $options{'carp'}; EOF meta::function('serialize', <<'EOF'); my @keys = sort keys %data; join "\n", $data{'bootstrap::initialization'}, map(serialize_single($_), grep( /^meta::/, @keys), grep(!/^meta::/, @keys)), "internal::main();", "__END__"; EOF meta::function('serialize_single', <<'EOF'); my ($namespace, $name) = split /::/, $_[0], 2; my $marker = '__' . fast_hash($data{$_[0]}); "meta::$namespace('$name', <<'$marker');\n$data{$_[0]}\n$marker"; EOF meta::function('fnv_hash', <<'EOF'); my ($data) = @_; my ($fnv_prime, $fnv_offset) = (16777619, 2166136261); my $hash = $fnv_offset; my $modulus = 2 ** 32; $hash = ($hash ^ ($_ & 0xffff) ^ ($_ >> 16)) * $fnv_prime % $modulus for unpack 'L*', $data . substr($data, -4) x 8; $hash; EOF meta::function('fast_hash', <<'EOF'); my ($data) = @_; my $piece_size = length($data) >> 3; my @pieces = (substr($data, $piece_size * 8) . length($data), map(substr($data, $piece_size * $_, $piece_size), 0 .. 7)); my @hashes = (fnv_hash($pieces[0])); push @hashes, fnv_hash($pieces[$_ + 1] . $hashes[$_]) for 0 .. 7; $hashes[$_] ^= $hashes[$_ + 4] >> 16 | ($hashes[$_ + 4] & 0xffff) << 16 for 0 .. 3; $hashes[0] ^= $hashes[8]; sprintf '%08x' x 4, @hashes[0 .. 3]; EOF meta::function('state', <<'EOF'); fast_hash(serialize()); EOF meta::function('verify', <<'EOF'); my $serialized_data = serialize(); my $state = state(); my $temporary_filename = "$0.$state"; open my $file, '>', $temporary_filename; print $file $serialized_data; close $file; chmod 0700, $temporary_filename; chomp(my $observed_state = join '', qx|perl '$temporary_filename' state|); my $result = $observed_state eq $state; unlink $temporary_filename if $result; $result; EOF meta::function('save', <<'EOF'); if (verify()) { open my $file, '>', $0; print $file serialize(); close $file; chmod 0744, $0; } else { warn 'Verification failed'; } EOF meta::function('ls', <<'EOF'); join "\n", sort keys %data; EOF meta::function('cp', <<'EOF'); associate($_[1], retrieve($_[0])); EOF meta::function('rm', <<'EOF'); delete @data{@_}; EOF meta::function('cat', <<'EOF'); join "\n", @data{@_}; EOF meta::function('create', <<'EOF'); return edit($_[0]) if exists $data{$_[0]}; associate($_[0], $_[1] || "# Attribute $_[0]"); edit($_[0]); EOF meta::function('set', <<'EOF'); $data{$_[0]} = join '', ; EOF meta::function('complete', <<'EOF'); my @functions = sort keys %externalized_functions; my @attributes = sort keys %data; sub match { my ($text, @options) = @_; my @matches = sort grep /^$text/, @options; if (@matches == 0) {return undef;} elsif (@matches == 1) {return $matches [0];} elsif (@matches > 1) { return ((longest ($matches [0], $matches [@matches - 1])), @matches); } } sub longest { my ($s1, $s2) = @_; return substr ($s1, 0, length $1) if ($s1 ^ $s2) =~ /^(\0*)/; return ''; } my ($text, $line) = @_; if ($line =~ / /) { # Start matching attribute names. match ($text, @attributes); } else { # Start of line, so it's a function. match ($text, @functions); } EOF meta::internal_function('shell', <<'EOF'); use Term::ReadLine; my $term = new Term::ReadLine "$0 shell"; $term->ornaments(0); my $output = $term->OUT || \*STDOUT; $term->Attribs->{attempted_completion_function} = \&complete; while (defined($_ = $term->readline("$0\$ "))) { my @args = grep length, split /\s+|("[^"\\]*(?:\\.)?")/o; my $function_name = shift @args; s/^"(.*)"$/\1/o, s/\\\\"/"/go for @args; if ($function_name) { if ($externalized_functions{$function_name}) { chomp(my $result = eval {&$function_name(@args)}); warn $@ if $@; print $output $result, "\n" unless $@; } else { warn "Command not found: '$function_name' (use 'ls' to see available commands)"; } } } EOF meta::function('edit', <<'EOF'); my $filename = '/tmp/' . rand(); open my $file, '>', $filename; print $file retrieve($_[0]); close $file; system($ENV{EDITOR} || $ENV{VISUAL} || '/usr/bin/nano', $filename); open my $file, '<', $filename; associate($_[0]}, join '', <$file>); close $file; EOF meta::internal_function('internal::main', <<'EOF'); my $initial_state = state(); my $command = shift @ARGV || retrieve('data::default-action'); print &$command(@ARGV); save() if state() ne $initial_state; EOF internal::main(); __END__ - end __ meta::section('virtual-attributes', <<'__'); - sc Virtual attributes In the last chapter, {\tt retrieve} was defined to grab either an attribute or a file. But there are a lot more things you might want to do with it, including creating views of existing data. This is exactly what virtual attributes are about. - s1 Core implementation Here's an updated {\tt retrieve}: - resource snippets/updated-retrieve << end meta::internal_function('retrieve', <<'EOF'); my @results = map defined $data{$_} ? $data{$_} : retrieve_with_hooks($_), @_; wantarray ? @results : $results[0]; EOF - end This is exactly the same as the one before except that the hard-coded {\tt file::read} call has been replaced by a call to \verb|retrieve_with_hooks|. This provides the indirection necessary to allow the user to introduce arbitrary retrievers. Before the user can do this, though, we'll need to make a new namespace: - resource snippets/meta-retriever << end meta::meta('type::retriever', <<'EOF'); meta::configure 'retriever', extension => '.pl', inherit => 1; meta::define_form 'retriever', sub { my ($name, $value) = @_; $transient{retrievers}{$name} = meta::eval_in("sub {\n$value\n}", "retriever::$name"); }; EOF - end Nothing particularly interesting is going on here. We're just maintaining a ${\rm name} \rightarrow {\rm implementation}$ mapping in \verb|%transient|. This mapping is then used by \verb|retrieve_with_hooks|, which asks {\tt retriever::} functions for their values until one of them returns something besides {\tt undef}: - resource snippets/retrieve-with-hooks << end meta::internal_function('retrieve_with_hooks', <<'EOF'); # Uses the hooks defined in $transient{retrievers}, and returns undef if none work. my ($attribute) = @_; my $result = undef; defined($result = &$_($attribute)) and return $result for map $transient{retrievers}{$_}, sort keys %{$transient{retrievers}}; return undef; EOF - end - s1 Retrievers in {\tt object} {\tt object} comes with four retrievers: - enumerate << end - item[] {\tt retriever::file} Retrieves contents from a filename. This lets you say things like {\tt cat foo}, where {\tt foo} is a file. By extension, you can also copy files into named attributes using {\tt function::cp}. - resource snippets/retriever-file << end meta::retriever('file', <<'EOF'); -f $_[0] ? file::read($_[0]) : undef; EOF - end - item[] {\tt retriever::id} Retrieves the string you are retrieving. This is primarily useful when you want a quick test value for something. For instance {\tt cat id::foobar} will print {\tt foobar}. Note that {\tt id::} is not defined as a namespace, it's just a name pattern detected by {\tt retriever::id}. - resource snippets/retriever-id << end meta::retriever('id', <<'EOF'); $_[0] =~ /^id::/ ? substr($_[0], 4) : undef; EOF - end - item[] {\tt retriever::object} This is a fun one. It lets you ask other Perl objects for their attributes. For example, {\tt cat object::./foo::function::ls} fetches {\tt function::ls} from {\tt ./foo}. If {\tt ./foo} is unreachable or doesn't contain {\tt function::ls}, then {\tt undef} is returned (which allows other retrievers to try to resolve your virtual attribute). - resource snippets/retriever-object << end meta::retriever('object', <<'EOF'); # Fetch a property from another Perl object. This uses the 'cat' function. return undef unless $_[0] =~ /^object::(.*?)::(.*)$/ && -x $1 && qx|$1 is '$2'|; join '', qx|$1 cat '$2'|; EOF - end - item[] {\tt retriever::perl} This returns the result of evaluating a given Perl expression. For example, {\tt cat perl::3+4} prints {\tt 7}. - resource snippets/retriever-perl << end meta::retriever('perl', <<'EOF'); # Lets you use the result of evaluating some Perl expression return undef unless $_[0] =~ /^perl::(.*)$/; eval $1; EOF - end - end As you can see, there's not much involved in writing a retriever. The only particularly counterintuitive thing about it is returning {\tt undef} instead of {\tt 0} or the empty string. - Fixing up {\tt edit} Right now, {\tt function::edit} will happily let you edit a virtual attribute and then attempt to {\tt associate} it, causing a failure. This is obviously lame; here's a better {\tt edit} function that takes care of this: - resource snippets/updated-edit << end meta::function('edit', <<'EOF'); my ($name, %options) = @_; my $extension = extension_for($name); die "$name is virtual or does not exist" unless exists $data{$name}; associate($name, invoke_editor_on($data{$name} // '', %options, attribute => $name, extension => $extension), execute => 1)}); save() unless $data{'data::edit::no-save'}; ''; EOF - end - More interesting retrievers I'm writing this document in a self-modifying Perl file that includes a simple preprocessor.\footnote{Unsurprisingly, it's called {\tt preprocessor} in the {\tt perl-objects} repository.} In order to make this work, there are a bunch of attributes in the {\tt section::} namespace, and each one includes some preprocessor directives to either include other attributes or to generate \TeX{} constructs (in some cases both). The easiest way to render the document as \TeX{} is to just have a virtual attribute I can retrieve that will contain the fully preprocessed source. Fortunately, {\tt preprocessor} provides {\tt retriever::pp} that does exactly this. Here's what that looks like: - resource snippets/retriever-pp << end meta::retriever('pp', <<'EOF'); return undef unless namespace($_[0]) eq 'pp'; my $attr = retrieve(attribute($_[0])); defined $attr ? preprocess($attr) : undef; EOF - end Notice that this retriever itself calls {\tt retrieve}! This is totally allowed as long as you don't create an infinite loop. Here, we're trimming the {\tt pp::} from the beginning of the attribute and are just retrieving the rest of it. This is good practice, as it lets you combine virtual retrievers. For example, you could preprocess an external file by saying {\tt cat pp::my-file}. Another interesting retriever is the {\tt http} retriever defined in {\tt repository}. This lets you retrieve arbitrary web content through Perl's LWP library: - resource snippets/retriever-http << end meta::retriever('http', <<'EOF'); use LWP::Simple (); return undef unless $_[0] =~ /^(?:http:)?\/\/(\w+.*)$/; LWP::Simple::get("http://$1"); EOF - end If you have this retriever, you can say things like {\tt cat http://google.com} (or shorter, {\tt cat //google.com}) and get back the content sent by the web server. This is especially useful when combined with the preprocessor, as it allows you to compile web-based resources into the final output. __ meta::template('comment', '\'\'; # A mechanism for line or block comments.'); meta::template('eval', <<'__'); my $result = eval $_[0]; terminal::warning("Error during template evaluation: $@") if $@; $result; __ meta::template('failing_conditional', <<'__'); my ($commands) = @_; my $should_return = $commands =~ / if (.*)$/ && ! eval $1; terminal::warning("eval of template condition failed: $@") if $@; $should_return; __ meta::template('include', <<'__'); my ($commands) = @_; return '' if template::failing_conditional($commands); join "\n", map retrieve($_), split /\s+/, $commands; __ meta::template('item[]', '"\\\\item[$_[0]]";'); meta::template('pinclude', <<'__'); # Just like the regular include, but makes sure to insert paragraph boundaries # (this is required for SDoc to function properly). my ($commands) = @_; return '' if template::failing_conditional($commands); my $text = join "\n\n", map retrieve($_), split /\s+/, $commands; "\n\n$text\n\n"; __ meta::template('script-include', <<'__'); my ($name) = @_; my $s = 'script'; my $script = retrieve($name); "<$s>\n$script\n"; __ meta::template('style-include', <<'__'); my ($name) = @_; my $s = 'style'; my $style = retrieve($name); "<$s>\n$style\n"; __ meta::vim_highlighter('cltex', <<'__'); " Cleaner TeX " Maintainer: Spencer Tipping " Language: Cleaner TeX (a variant of LaTeX with support for a bunch of embedded languages) if version < 600 syntax clear elseif exists("b:current_syntax") finish endif syn match cltEofMarker /<<\s*\w\+/ contained syn region cltLineComment matchgroup=cltCode start=/^\s*- comment / end=/$/ contained syn match cltLine /^\s*- .*$/ contains=cltEofMarker,cltLineComment syn case match | syn include @cpp syntax/cpp.vim | unlet b:current_syntax syn case match | syn include @java syntax/java.vim | unlet b:current_syntax syn case match | syn include @asm syntax/asm.vim | unlet b:current_syntax syn case match | syn include @javascript syntax/javascript.vim | unlet b:current_syntax syn case match | syn include @html syntax/html.vim | unlet b:current_syntax syn case match | syn include @perl syntax/perl.vim | unlet b:current_syntax syn case match | syn include @ruby syntax/ruby.vim | unlet b:current_syntax syn case match syn region cltCpp matchgroup=cltCode start=/^\z(\s*\)- cpp .*<<\s*\z(\w\+\)$/ end=/^\z1- \z2$/ contains=@cpp syn region cltJava matchgroup=cltCode start=/^\z(\s*\)- java .*<<\s*\z(\w\+\)$/ end=/^\z1- \z2$/ contains=@java syn region cltAsm matchgroup=cltCode start=/^\z(\s*\)- asm .*<<\s*\z(\w\+\)$/ end=/^\z1- \z2$/ contains=@asm syn region cltJavascript matchgroup=cltCode start=/^\z(\s*\)- javascript .*<<\s*\z(\w\+\)$/ end=/^\z1- \z2$/ contains=@javascript syn region cltHtml matchgroup=cltCode start=/^\z(\s*\)- html .*<<\s*\z(\w\+\)$/ end=/^\z1- \z2$/ contains=@html syn region cltPerl matchgroup=cltCode start=/^\z(\s*\)- perl .*<<\s*\z(\w\+\)$/ end=/^\z1- \z2$/ contains=@perl syn region cltRuby matchgroup=cltCode start=/^\z(\s*\)- ruby .*<<\s*\z(\w\+\)$/ end=/^\z1- \z2$/ contains=@ruby syn region cltResource matchgroup=cltCode start=/^\z(\s*\)- resource .*<<\s*\z(\w\+\)$/ end=/^\z1- \z2$/ syn region cltComment matchgroup=cltCode start=/^\z(\s*\)- comment .*<<\s*\z(\w\+\)$/ end=/^\z1- \z2$/ syn cluster cltStuff add=cltCpp,cltJava,cltAsm,cltJavascript,cltHtml,cltResource,cltComment,cltLine,cltPerl,cltRuby syn region cltDocument start=/\%^/ end=/\%$/ contains=@cltStuff hi link cltLine Special hi link cltKeyword String hi link cltResource String hi link cltEofMarker String hi link cltCode Special hi link cltDocument Comment hi link cltComment Type hi link cltLineComment Type let b:current_syntax = "cltex" __ internal::main(); __END__