view release on metacpan or  search on metacpan

lib/Developer/Dashboard/Zipper.pm  view on Meta::CPAN

    my $code = <$fh>;
    close $fh;
    return $code;
}

# _saved_ajax_url(%args)
# Builds the stable runtime URL for one saved bookmark Ajax handler.
# Input: file, type, and optional base_url/singleton values.
# Output: hash reference with url string.
sub _saved_ajax_url {
    my (%args) = @_;
    my $file = _validate_saved_ajax_file( $args{file} );
    my $route = _saved_skill_ajax_route_spec(
        skill_name => $args{skill_name} || '',
        file       => $file,
    );
    my $path = $route
      ? ( $route->{path} || '' )
      : (
        ( $args{skill_name} || '' ) ne ''
        ? sprintf '/ajax/%s/%s', _url_path_escape( $args{skill_name} ), _url_path_escape($file)
        : sprintf '/ajax/%s', _url_path_escape($file)
      );
    my $query = $path;
    if ( !$route ) {
        $query = sprintf '%s?type=%s',
          $path,
          uri_escape( $args{type} || 'text' );
    }
    if ( defined $args{singleton} && $args{singleton} ne '' ) {
        $query .= ( $query =~ /\?/ ? '&' : '?' ) . 'singleton=' . uri_escape( $args{singleton} );
    }
    return {
        url => ( $args{base_url} || '' ) . $query,
    };
}

# _saved_skill_ajax_route_spec(%args)
# Resolves the canonical custom route metadata for one skill-local saved Ajax file.
# Input: skill_name string and relative ajax file path.
# Output: hash reference route spec or undef when the skill has no custom route.
sub _saved_skill_ajax_route_spec {
    my (%args) = @_;
    my $skill_name = $args{skill_name} || '';
    return if $skill_name eq '';
    my $context = ref($AJAX_CONTEXT) eq 'HASH' ? $AJAX_CONTEXT : {};
    my $paths = $context->{paths};
    return if !blessed($paths);
    require Developer::Dashboard::SkillDispatcher;
    my $dispatcher = Developer::Dashboard::SkillDispatcher->new( paths => $paths );
    return $dispatcher->skill_ajax_route_spec( $skill_name, $args{file} || '' );
}

# _url_path_escape($path)
# Escapes one slash-delimited route fragment without collapsing path separators.
# Input: relative path string.
# Output: URL-safe path string with each segment escaped independently.
sub _url_path_escape {
    my ($path) = @_;
    return '' if !defined $path || $path eq '';
    return join '/', map { uri_escape($_) } split m{/+}, $path;
}

# _saved_ajax_url_and_store(%args)
# Stores saved bookmark Ajax code under the dashboards ajax tree and returns the stable runtime URL.
# Input: runtime_root, file, type, code, and optional base_url/singleton values.
# Output: hash reference with url and file path.
sub _saved_ajax_url_and_store {
    my (%args) = @_;
    my $path = saved_ajax_file_path(%args);
    my $dir = dirname($path);
    make_path($dir) if !-d $dir;
    open my $fh, '>', $path or die "Unable to write $path: $!";
    print {$fh} defined $args{code} ? $args{code} : '';
    close $fh;
    chmod 0700, $path or die "Unable to chmod $path: $!";
    return {
        path => $path,
        %{ _saved_ajax_url(%args) },
    };
}

# _validate_saved_ajax_file($file)
# Validates a relative saved bookmark Ajax file name for stable dashboards ajax-tree storage.
# Input: requested file name string.
# Output: normalized relative file name string.
sub _validate_saved_ajax_file {
    my ($file) = @_;
    die "file is required" if !defined $file || $file eq '';
    die "file must be relative" if File::Spec->file_name_is_absolute($file);
    die "file contains invalid parent traversal" if $file =~ m{(?:\A|/)\.\.(?:/|\z)};
    die "file contains invalid characters" if $file !~ m{\A[A-Za-z0-9][A-Za-z0-9._/-]*\z};
    return $file;
}

# __cmdx($type, $code)
# Returns a shell pipeline string that decodes an encoded payload.
# Input: type string and code string.
# Output: shell command string.
sub __cmdx {
    my ( $type, $code ) = @_;
    my $token = zip($code) || { raw => '' };
    return "printf '%s' " . quotemeta( $token->{raw} ) . " | base64 -d | gunzip";
}

# _cmdx($type, $code)
# Returns older shell execution tuple values.
# Input: type string and code string.
# Output: list of shell tuple values.
sub _cmdx {
    my ( $type, $code ) = @_;
    my $switch = $type eq 'perl' ? '-e' : '-c';
    return ( $type, $switch, __cmdx( $type, $code ) );
}

# _cmdp($type, $code)
# Returns older shell pipeline tuple values.
# Input: type string and code string.
# Output: list of pipeline tuple values.
sub _cmdp {
    my ( $type, $code ) = @_;