view release on metacpan or  search on metacpan

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

our @EXPORT = qw(zip unzip _cmdx _cmdp __cmdx acmdx Ajax);
our $AJAX_CONTEXT = {};

# zip($text)
# Encodes a text payload to the older token structure.
# Input: plain text string.
# Output: hash with raw and url token values.
sub zip {
    my ($text) = @_;
    return if !defined $text || $text eq '';
    my $raw = encode_payload($text);
    return {
        raw => $raw,
        url => uri_escape($raw),
    };
}

# unzip($token)
# Decodes a older token payload back to text.
# Input: encoded token string.
# Output: plain text string.
sub unzip {
    my ($token) = @_;
    return if !defined $token || $token eq '';
    return decode_payload($token);
}

# acmdx(%args)
# Builds a older ajax/action URL bundle for encoded code execution.
# Input: path, type, target, label, code, and optional app/save/base_url/singleton values.
# Output: hash with token, url, forward, and html keys.
sub acmdx {
    my %args = @_;
    my $type = $args{type} || 'text';
    my $path = $args{path} || '/ajax';
    my $code = $args{code} // '';
    my $base = $args{base_url} || '';
    my $token = zip($code) || { raw => '', url => '' };
    my $query = sprintf '%s?token=%s&type=%s', $path, $token->{url}, uri_escape($type);
    if ( defined $args{singleton} && $args{singleton} ne '' ) {
        $query .= '&singleton=' . uri_escape( $args{singleton} );
    }
    my $url = $base ? $base . $query : $query;
    my $app_url = $args{app};
    $app_url = $url if !$app_url;
    return {
        token   => $token,
        url     => { tokenised => $url, app => $app_url },
        forward => [ $path => { token => $token->{raw}, type => $type } ],
        html    => sprintf(
            q{<a href="%s" target="%s">%s</a>},
            _escape_html_attr($url),
            _escape_html_attr( $args{target} || '_blank' ),
            _escape_html( $args{label} || 'Click Here' ),
        ),
    };
}

# Ajax(%args)
# Prints a older config-binding script for an encoded ajax endpoint.
# Input: jvar, type, optional file/singleton names, and optional code values.
# Output: hide marker string.
# DD-895: $path (the jvar substring after the first '.') and the ajax url
# are both JS STRING content in the emitted <script> tag, so both go
# through _js_single_quote before interpolation - matching how
# $args{singleton} was already correctly handled two lines away. $root
# (the jvar substring before the first '.') stays unescaped by design: it
# is interpolated as a bare JS identifier/property-access expression
# (e.g. `window` or `someObj`), not as string content, so JS-string
# escaping would be the wrong treatment for it.
sub Ajax {
    my %args = @_;
    die "jvar is required" if !$args{jvar};
    my $type = $args{type} || 'text';
    my $code = _render_ajax_code_template( $args{code}, $args{data} );
    my $context = ref($AJAX_CONTEXT) eq 'HASH' ? $AJAX_CONTEXT : {};
    if ( ( ( $context->{source} || '' ) eq 'saved' || ( $context->{source} || '' ) eq 'skill' ) && ( $context->{page_id} || '' ) ne '' ) {
        my $file = $args{file} || '';
        if ( $file eq '' && !( $context->{allow_transient_urls} || 0 ) ) {
            die "file is required for saved bookmark Ajax when transient URL tokens are disabled";
        }
        if ( $file ne '' ) {
            my $saved = defined $args{code}
              ? _saved_ajax_url_and_store(
                file         => $file,
                page_id      => $context->{page_id},
                runtime_root => $context->{runtime_root} || '',
                skill_name   => $context->{skill_name} || '',
                type         => $type,
                code         => $code,
                singleton    => $args{singleton},
                base_url     => $args{base_url} || '',
              )
              : _saved_ajax_url(
                file      => $file,
                page_id   => $context->{page_id},
                skill_name => $context->{skill_name} || '',
                type      => $type,
                singleton => $args{singleton},
                base_url  => $args{base_url} || '',
                );
                my ( $root, $path ) = split /\./, $args{jvar}, 2;
                $path ||= '';
                print sprintf qq{<script>set_chain_value(%s,'%s','%s')</script>}, $root,
                  _js_single_quote($path), _js_single_quote( $saved->{url} );
                print sprintf qq{<script>dashboard_ajax_singleton_cleanup('%s')</script>}, _js_single_quote( $args{singleton} )
                  if defined $args{singleton} && $args{singleton} ne '';
                return 'HIDE-THIS';
            }
        }
    my $ajax = acmdx(
        %args,
        code => $code,
        path => '/ajax',
        type => $type,
    );
    my ( $root, $path ) = split /\./, $args{jvar}, 2;
    $path ||= '';
    print sprintf qq{<script>set_chain_value(%s,'%s','%s')</script>}, $root,
      _js_single_quote($path), _js_single_quote( $ajax->{url}{tokenised} );

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

# 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 ) = @_;
    return ( __cmdx( $type, $code ), $type );
}

1;

__END__

=head1 NAME

Developer::Dashboard::Zipper - older token encoding and ajax URL compatibility helpers

=head1 SYNOPSIS

  use Developer::Dashboard::Zipper qw(zip unzip Ajax);
  my $token = zip("print qq{ok\\n};");

=head1 DESCRIPTION

This module recreates the small token and ajax helper surface expected by
older bookmark code without carrying forward any project-specific logic.

=head1 FUNCTIONS

=head2 zip, unzip, acmdx, Ajax, __cmdx, _cmdx, _cmdp

Encode and decode token payloads and generate older-style ajax links. Saved
bookmark Ajax file handlers are stored under the dashboards ajax tree as
executable files so the web runtime can run them as real processes.
When callers supply C<data>, C<Ajax> renders its C<code> string with Template
Toolkit before either storing a saved handler or encoding a transient token.
This ordering ensures the encoded payload contains executable Perl rather than
unrendered C<[% ... %]> directives.

=for comment FULL-POD-DOC START

=head1 PURPOSE

This module keeps the older bookmark and Ajax helper compatibility surface alive. It builds tokenised URLs, saved Ajax endpoints, and helper snippets such as C<Ajax()> while routing the actual encoding work through the modern codec module.

=head1 WHY IT EXISTS

It exists because older bookmarks still expect the historical helper names and URL-building patterns. Keeping those wrappers in one module preserves compatibility without forcing newer runtime code to keep re-implementing the old API directly.

=head1 WHEN TO USE

Use this file when changing older Ajax helper behavior, saved Ajax file validation, token URL generation, or the compatibility wrappers that older bookmark instructions still reference.

=head1 HOW TO USE

Import the specific helper you need, such as C<zip>, C<unzip>, or C<Ajax>, and let this module generate the compatibility structure or snippet. Newer code should prefer the lower-level runtime and codec modules where possible.

=head1 WHAT USES IT

It is used by older bookmark pages, by saved Ajax compatibility paths, by page-runtime helper injection, and by tests that guard the backward-compatible helper layer.

=head1 EXAMPLES

Example 1:

  perl -Ilib -MDeveloper::Dashboard::Zipper -e 1

Do a direct compile-and-load check against the module from a source checkout.

Example 2:

  prove -lv t/21-refactor-coverage.t t/00-load.t

Run the focused regression tests that most directly exercise this module's behavior.

Example 3:

  HARNESS_PERL_SWITCHES=-MDevel::Cover prove -lr t

Recheck the module under the repository coverage gate rather than relying on a load-only probe.

Example 4:

  prove -lr t

Put any module-level change back through the entire repository suite before release.


=for comment FULL-POD-DOC END

=cut