STLExtract 1.0.0

data/Slic3r/Linux/lib/std/Sub/Defer.pm

@@ -0,0 +1,141 @@
+package Sub::Defer;
+
+use strictures 1;
+use base qw(Exporter);
+use Moo::_Utils;
+use Scalar::Util qw(weaken);
+
+our $VERSION = '1.005000';
+$VERSION = eval $VERSION;
+
+our @EXPORT = qw(defer_sub undefer_sub undefer_all);
+
+our %DEFERRED;
+
+sub undefer_sub {
+  my ($deferred) = @_;
+  my ($target, $maker, $undeferred_ref) = @{
+    $DEFERRED{$deferred}||return $deferred
+  };
+  return ${$undeferred_ref}
+    if ${$undeferred_ref};
+  ${$undeferred_ref} = my $made = $maker->();
+
+  # make sure the method slot has not changed since deferral time
+  if (defined($target) && $deferred eq *{_getglob($target)}{CODE}||'') {
+    no warnings 'redefine';
+
+    # I believe $maker already evals with the right package/name, so that
+    # _install_coderef calls are not necessary --ribasushi
+    *{_getglob($target)} = $made;
+  }
+  $DEFERRED{$made} = $DEFERRED{$deferred};
+  weaken $DEFERRED{$made}
+    unless $target;
+
+  return $made;
+}
+
+sub undefer_all {
+  undefer_sub($_) for keys %DEFERRED;
+  return;
+}
+
+sub defer_info {
+  my ($deferred) = @_;
+  my $info = $DEFERRED{$deferred||''} or return undef;
+  [ @$info ];
+}
+
+sub defer_sub {
+  my ($target, $maker) = @_;
+  my $undeferred;
+  my $deferred_info;
+  my $deferred = sub {
+    $undeferred ||= undefer_sub($deferred_info->[3]);
+    goto &$undeferred;
+  };
+  $deferred_info = [ $target, $maker, \$undeferred, $deferred ];
+  weaken($deferred_info->[3]);
+  weaken($DEFERRED{$deferred} = $deferred_info);
+  _install_coderef($target => $deferred) if defined $target;
+  return $deferred;
+}
+
+sub CLONE {
+  %DEFERRED = map { defined $_ && $_->[3] ? ($_->[3] => $_) : () } values %DEFERRED;
+  for my $info (values %DEFERRED) {
+    weaken($info)
+      unless $info->[0] && ${$info->[2]};
+  }
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Sub::Defer - defer generation of subroutines until they are first called
+
+=head1 SYNOPSIS
+
+ use Sub::Defer;
+
+ my $deferred = defer_sub 'Logger::time_since_first_log' => sub {
+    my $t = time;
+    sub { time - $t };
+ };
+
+  Logger->time_since_first_log; # returns 0 and replaces itself
+  Logger->time_since_first_log; # returns time - $t
+
+=head1 DESCRIPTION
+
+These subroutines provide the user with a convenient way to defer creation of
+subroutines and methods until they are first called.
+
+=head1 SUBROUTINES
+
+=head2 defer_sub
+
+ my $coderef = defer_sub $name => sub { ... };
+
+This subroutine returns a coderef that encapsulates the provided sub - when
+it is first called, the provided sub is called and is -itself- expected to
+return a subroutine which will be goto'ed to on subsequent calls.
+
+If a name is provided, this also installs the sub as that name - and when
+the subroutine is undeferred will re-install the final version for speed.
+
+=head2 undefer_sub
+
+ my $coderef = undefer_sub \&Foo::name;
+
+If the passed coderef has been L<deferred|/defer_sub> this will "undefer" it.
+If the passed coderef has not been deferred, this will just return it.
+
+If this is confusing, take a look at the example in the L</SYNOPSIS>.
+
+=head2 undefer_all
+
+ undefer_all();
+
+This will undefer all defered subs in one go.  This can be very useful in a
+forking environment where child processes would each have to undefer the same
+subs.  By calling this just before you start forking children you can undefer
+all currently deferred subs in the parent so that the children do not have to
+do it.
+
+=head1 SUPPORT
+
+See L<Moo> for support and contact information.
+
+=head1 AUTHORS
+
+See L<Moo> for authors.
+
+=head1 COPYRIGHT AND LICENSE
+
+See L<Moo> for the copyright and license.
+
+=cut

data/Slic3r/Linux/lib/std/Sub/Exporter/Progressive.pm

@@ -0,0 +1,158 @@
+package Sub::Exporter::Progressive;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.001011';
+
+use Carp ();
+use List::Util ();
+
+sub import {
+   my ($self, @args) = @_;
+
+   my $inner_target = caller;
+   my $export_data = sub_export_options($inner_target, @args);
+
+   my $full_exporter;
+   no strict 'refs';
+   @{"${inner_target}::EXPORT_OK"} = @{$export_data->{exports}};
+   @{"${inner_target}::EXPORT"} = @{$export_data->{defaults}};
+   %{"${inner_target}::EXPORT_TAGS"} = %{$export_data->{tags}};
+   *{"${inner_target}::import"} = sub {
+      use strict;
+      my ($self, @args) = @_;
+
+      if (List::Util::first { ref || !m/ \A [:-]? \w+ \z /xm } @args) {
+         Carp::croak 'your usage of Sub::Exporter::Progressive requires Sub::Exporter to be installed'
+            unless eval { require Sub::Exporter };
+         $full_exporter ||= Sub::Exporter::build_exporter($export_data->{original});
+
+         goto $full_exporter;
+      } elsif (defined(my $num = List::Util::first { !ref and m/^\d/ } @args)) {
+         die "cannot export symbols with a leading digit: '$num'";
+      } else {
+         require Exporter;
+         s/ \A - /:/xm for @args;
+         @_ = ($self, @args);
+         goto \&Exporter::import;
+      }
+   };
+   return;
+}
+
+my $too_complicated = <<'DEATH';
+You are using Sub::Exporter::Progressive, but the features your program uses from
+Sub::Exporter cannot be implemented without Sub::Exporter, so you might as well
+just use vanilla Sub::Exporter
+DEATH
+
+sub sub_export_options {
+   my ($inner_target, $setup, $options) = @_;
+
+   my @exports;
+   my @defaults;
+   my %tags;
+
+   if ($setup eq '-setup') {
+      my %options = %$options;
+
+      OPTIONS:
+      for my $opt (keys %options) {
+         if ($opt eq 'exports') {
+
+            Carp::croak $too_complicated if ref $options{exports} ne 'ARRAY';
+            @exports = @{$options{exports}};
+            Carp::croak $too_complicated if List::Util::first { ref } @exports;
+
+         } elsif ($opt eq 'groups') {
+            %tags = %{$options{groups}};
+            for my $tagset (values %tags) {
+               Carp::croak $too_complicated if List::Util::first { / \A - (?! all \b ) /x || ref } @{$tagset};
+            }
+            @defaults = @{$tags{default} || [] };
+         } else {
+            Carp::croak $too_complicated;
+         }
+      }
+      @{$_} = map { / \A  [:-] all \z /x ? @exports : $_ } @{$_} for \@defaults, values %tags;
+      $tags{all} ||= [ @exports ];
+      my %exports = map { $_ => 1 } @exports;
+      my @errors = grep { not $exports{$_} } @defaults;
+      Carp::croak join(', ', @errors) . " is not exported by the $inner_target module\n" if @errors;
+   }
+
+   return {
+      exports => \@exports,
+      defaults => \@defaults,
+      original => $options,
+      tags => \%tags,
+   };
+}
+
+1;
+
+=encoding utf8
+
+=head1 NAME
+
+Sub::Exporter::Progressive - Only use Sub::Exporter if you need it
+
+=head1 SYNOPSIS
+
+ package Syntax::Keyword::Gather;
+
+ use Sub::Exporter::Progressive -setup => {
+   exports => [qw( break gather gathered take )],
+   groups => {
+     default => [qw( break gather gathered take )],
+   },
+ };
+
+ # elsewhere
+
+ # uses Exporter for speed
+ use Syntax::Keyword::Gather;
+
+ # somewhere else
+
+ # uses Sub::Exporter for features
+ use Syntax::Keyword::Gather 'gather', take => { -as => 'grab' };
+
+=head1 DESCRIPTION
+
+L<Sub::Exporter> is an incredibly powerful module, but with that power comes
+great responsibility, er- as well as some runtime penalties.  This module
+is a C<Sub::Exporter> wrapper that will let your users just use L<Exporter>
+if all they are doing is picking exports, but use C<Sub::Exporter> if your
+users try to use C<Sub::Exporter>'s more advanced features, like
+renaming exports, if they try to use them.
+
+Note that this module will export C<@EXPORT>, C<@EXPORT_OK> and
+C<%EXPORT_TAGS> package variables for C<Exporter> to work.  Additionally, if
+your package uses advanced C<Sub::Exporter> features like currying, this module
+will only ever use C<Sub::Exporter>, so you might as well use it directly.
+
+=head1 AUTHOR
+
+frew - Arthur Axel Schmidt (cpan:FREW) <frioux+cpan@gmail.com>
+
+=head1 CONTRIBUTORS
+
+ilmari - Dagfinn Ilmari Mannsåker (cpan:ILMARI) <ilmari@ilmari.org>
+
+mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>
+
+leont - Leon Timmermans (cpan:LEONT) <leont@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2012 the Sub::Exporter::Progressive L</AUTHOR> and
+L</CONTRIBUTORS> as listed above.
+
+=head1 LICENSE
+
+This library is free software and may be distributed under the same terms
+as perl itself.
+
+=cut

data/Slic3r/Linux/lib/std/Sub/Quote.pm

@@ -0,0 +1,368 @@
+package Sub::Quote;
+
+use strictures 1;
+
+sub _clean_eval { eval $_[0] }
+
+use Sub::Defer;
+use Scalar::Util qw(weaken);
+use base qw(Exporter);
+use B ();
+BEGIN {
+  *_HAVE_PERLSTRING = defined &B::perlstring ? sub(){1} : sub(){0};
+}
+
+our $VERSION = '1.005000';
+$VERSION = eval $VERSION;
+
+our @EXPORT = qw(quote_sub unquote_sub quoted_from_sub qsub);
+our @EXPORT_OK = qw(quotify capture_unroll inlinify);
+
+our %QUOTED;
+
+sub quotify {
+  ! defined $_[0]     ? 'undef()'
+  : _HAVE_PERLSTRING  ? B::perlstring($_[0])
+  : qq["\Q$_[0]\E"];
+}
+
+sub capture_unroll {
+  my ($from, $captures, $indent) = @_;
+  join(
+    '',
+    map {
+      /^([\@\%\$])/
+        or die "capture key should start with \@, \% or \$: $_";
+      (' ' x $indent).qq{my ${_} = ${1}{${from}->{${\quotify $_}}};\n};
+    } keys %$captures
+  );
+}
+
+sub inlinify {
+  my ($code, $args, $extra, $local) = @_;
+  my $do = 'do { '.($extra||'');
+  if ($code =~ s/^(\s*package\s+([a-zA-Z0-9:]+);)//) {
+    $do .= $1;
+  }
+  if ($code =~ s{(\A\s*|\A# BEGIN quote_sub PRELUDE\n.*?# END quote_sub PRELUDE\n\s*)(^\s*)(my\s*\(([^)]+)\)\s*=\s*\@_;)$}{
+    my ($pre, $indent, $assign, $code_args) = ($1, $2, $3, $4);
+    if ($code_args eq $args) {
+      $pre . $indent . ($local ? 'local ' : '').'@_ = ('.$args.");\n"
+      . $indent . $assign;
+    }
+    else {
+      $pre . 'my ('.$code_args.') = ('.$args.'); ';
+    }
+  }mse) {
+    #done
+  }
+  elsif ($local || $args ne '@_') {
+    $do .= ($local ? 'local ' : '').'@_ = ('.$args.'); ';
+  }
+  $do.$code.' }';
+}
+
+sub quote_sub {
+  # HOLY DWIMMERY, BATMAN!
+  # $name => $code => \%captures => \%options
+  # $name => $code => \%captures
+  # $name => $code
+  # $code => \%captures => \%options
+  # $code
+  my $options =
+    (ref($_[-1]) eq 'HASH' and ref($_[-2]) eq 'HASH')
+      ? pop
+      : {};
+  my $captures = ref($_[-1]) eq 'HASH' ? pop : undef;
+  undef($captures) if $captures && !keys %$captures;
+  my $code = pop;
+  my $name = $_[0];
+  my ($package, $hints, $bitmask, $hintshash) = (caller(0))[0,8,9,10];
+  my $context
+    ="# BEGIN quote_sub PRELUDE\n"
+    ."package $package;\n"
+    ."BEGIN {\n"
+    ."  \$^H = ".quotify($hints).";\n"
+    ."  \${^WARNING_BITS} = ".quotify($bitmask).";\n"
+    ."  \%^H = (\n"
+    . join('', map
+     "    ".quotify($_)." => ".quotify($hintshash->{$_}).",",
+      keys %$hintshash)
+    ."  );\n"
+    ."}\n"
+    ."# END quote_sub PRELUDE\n";
+  $code = "$context$code";
+  my $quoted_info;
+  my $unquoted;
+  my $deferred = defer_sub +($options->{no_install} ? undef : $name) => sub {
+    $unquoted if 0;
+    unquote_sub($quoted_info->[4]);
+  };
+  $quoted_info = [ $name, $code, $captures, \$unquoted, $deferred ];
+  weaken($quoted_info->[3]);
+  weaken($quoted_info->[4]);
+  weaken($QUOTED{$deferred} = $quoted_info);
+  return $deferred;
+}
+
+sub quoted_from_sub {
+  my ($sub) = @_;
+  my $quoted_info = $QUOTED{$sub||''} or return undef;
+  my ($name, $code, $captured, $unquoted, $deferred) = @{$quoted_info};
+  $unquoted &&= $$unquoted;
+  if (($deferred && $deferred eq $sub)
+      || ($unquoted && $unquoted eq $sub)) {
+    return [ $name, $code, $captured, $unquoted, $deferred ];
+  }
+  return undef;
+}
+
+sub unquote_sub {
+  my ($sub) = @_;
+  my $quoted = $QUOTED{$sub} or return undef;
+  my $unquoted = $quoted->[3];
+  unless ($unquoted && $$unquoted) {
+    my ($name, $code, $captures) = @$quoted;
+
+    my $make_sub = "{\n";
+
+    my %captures = $captures ? %$captures : ();
+    $captures{'$_UNQUOTED'} = \$unquoted;
+    $captures{'$_QUOTED'} = \$quoted;
+    $make_sub .= capture_unroll("\$_[1]", \%captures, 2);
+
+    $make_sub .= (
+      $name
+          # disable the 'variable $x will not stay shared' warning since
+          # we're not letting it escape from this scope anyway so there's
+          # nothing trying to share it
+        ? "  no warnings 'closure';\n  sub ${name} {\n"
+        : "  \$\$_UNQUOTED = sub {\n"
+    );
+    $make_sub .= "  \$_QUOTED if 0;\n";
+    $make_sub .= "  \$_UNQUOTED if 0;\n";
+    $make_sub .= $code;
+    $make_sub .= "  }".($name ? '' : ';')."\n";
+    if ($name) {
+      $make_sub .= "  \$\$_UNQUOTED = \\&${name}\n";
+    }
+    $make_sub .= "}\n1;\n";
+    $ENV{SUB_QUOTE_DEBUG} && warn $make_sub;
+    {
+      no strict 'refs';
+      local *{$name} if $name;
+      my ($success, $e);
+      {
+        local $@;
+        $success = _clean_eval($make_sub, \%captures);
+        $e = $@;
+      }
+      unless ($success) {
+        die "Eval went very, very wrong:\n\n${make_sub}\n\n$e";
+      }
+      weaken($QUOTED{$$unquoted} = $quoted);
+    }
+  }
+  $$unquoted;
+}
+
+sub qsub ($) {
+  goto &quote_sub;
+}
+
+sub CLONE {
+  %QUOTED = map { defined $_ ? (
+    $_->[3] && ${$_->[3]} ? (${ $_->[3] } => $_) : (),
+    $_->[4] ? ($_->[4] => $_) : (),
+  ) : () } values %QUOTED;
+  weaken($_) for values %QUOTED;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Sub::Quote - efficient generation of subroutines via string eval
+
+=head1 SYNOPSIS
+
+ package Silly;
+
+ use Sub::Quote qw(quote_sub unquote_sub quoted_from_sub);
+
+ quote_sub 'Silly::kitty', q{ print "meow" };
+
+ quote_sub 'Silly::doggy', q{ print "woof" };
+
+ my $sound = 0;
+
+ quote_sub 'Silly::dagron',
+   q{ print ++$sound % 2 ? 'burninate' : 'roar' },
+   { '$sound' => \$sound };
+
+And elsewhere:
+
+ Silly->kitty;  # meow
+ Silly->doggy;  # woof
+ Silly->dagron; # burninate
+ Silly->dagron; # roar
+ Silly->dagron; # burninate
+
+=head1 DESCRIPTION
+
+This package provides performant ways to generate subroutines from strings.
+
+=head1 SUBROUTINES
+
+=head2 quote_sub
+
+ my $coderef = quote_sub 'Foo::bar', q{ print $x++ . "\n" }, { '$x' => \0 };
+
+Arguments: ?$name, $code, ?\%captures, ?\%options
+
+C<$name> is the subroutine where the coderef will be installed.
+
+C<$code> is a string that will be turned into code.
+
+C<\%captures> is a hashref of variables that will be made available to the
+code.  The keys should be the full name of the variable to be made available,
+including the sigil.  The values should be references to the values.  The
+variables will contain copies of the values.  See the L</SYNOPSIS>'s
+C<Silly::dagron> for an example using captures.
+
+=head3 options
+
+=over 2
+
+=item * no_install
+
+B<Boolean>.  Set this option to not install the generated coderef into the
+passed subroutine name on undefer.
+
+=back
+
+=head2 unquote_sub
+
+ my $coderef = unquote_sub $sub;
+
+Forcibly replace subroutine with actual code.
+
+If $sub is not a quoted sub, this is a no-op.
+
+=head2 quoted_from_sub
+
+ my $data = quoted_from_sub $sub;
+
+ my ($name, $code, $captures, $compiled_sub) = @$data;
+
+Returns original arguments to quote_sub, plus the compiled version if this
+sub has already been unquoted.
+
+Note that $sub can be either the original quoted version or the compiled
+version for convenience.
+
+=head2 inlinify
+
+ my $prelude = capture_unroll '$captures', {
+   '$x' => 1,
+   '$y' => 2,
+ };
+
+ my $inlined_code = inlinify q{
+   my ($x, $y) = @_;
+
+   print $x + $y . "\n";
+ }, '$x, $y', $prelude;
+
+Takes a string of code, a string of arguments, a string of code which acts as a
+"prelude", and a B<Boolean> representing whether or not to localize the
+arguments.
+
+=head2 quotify
+
+ my $quoted_value = quotify $value;
+
+Quotes a single (non-reference) scalar value for use in a code string.  Numbers
+aren't treated specially and will be quoted as strings, but undef will quoted as
+C<undef()>.
+
+=head2 capture_unroll
+
+ my $prelude = capture_unroll '$captures', {
+   '$x' => 1,
+   '$y' => 2,
+ }, 4;
+
+Arguments: $from, \%captures, $indent
+
+Generates a snippet of code which is suitable to be used as a prelude for
+L</inlinify>.  C<$from> is a string will be used as a hashref in the resulting
+code.  The keys of C<%captures> are the names of the variables and the values
+are ignored.  C<$indent> is the number of spaces to indent the result by.
+
+=head2 qsub
+
+ my $hash = {
+  coderef => qsub q{ print "hello"; },
+  other   => 5,
+ };
+
+Arguments: $code
+
+Works exactly like L</quote_sub>, but includes a prototype to only accept a
+single parameter.  This makes it easier to include in hash structures or lists.
+
+=head1 CAVEATS
+
+Much of this is just string-based code-generation, and as a result, a few
+caveats apply.
+
+=head2 return
+
+Calling C<return> from a quote_sub'ed sub will not likely do what you intend.
+Instead of returning from the code you defined in C<quote_sub>, it will return
+from the overall function it is composited into.
+
+So when you pass in:
+
+   quote_sub q{  return 1 if $condition; $morecode }
+
+It might turn up in the intended context as follows:
+
+  sub foo {
+
+    <important code a>
+    do {
+      return 1 if $condition;
+      $morecode
+    };
+    <important code b>
+
+  }
+
+Which will obviously return from foo, when all you meant to do was return from
+the code context in quote_sub and proceed with running important code b.
+
+=head2 pragmas
+
+C<Sub::Quote> preserves the environment of the code creating the
+quoted subs.  This includes the package, strict, warnings, and any
+other lexical pragmas.  This is done by prefixing the code with a
+block that sets up a matching environment.  When inlining C<Sub::Quote>
+subs, care should be taken that user pragmas won't effect the rest
+of the code.
+
+=head1 SUPPORT
+
+See L<Moo> for support and contact information.
+
+=head1 AUTHORS
+
+See L<Moo> for authors.
+
+=head1 COPYRIGHT AND LICENSE
+
+See L<Moo> for the copyright and license.
+
+=cut