—

              
## -*- perl -*-
##----------------------------------------------------------------------------
## Markdown Parser Only - ~/lib/Markdown/Parser/Link.pm
## Version v0.3.0
## Copyright(c) 2022 DEGUEST Pte. Ltd.
## Author: Jacques Deguest <jack@deguest.jp>
## Created 2021/08/23
## Modified 2024/08/30
## All rights reserved
## 
## This program is free software; you can redistribute  it  and/or  modify  it
## under the same terms as Perl itself.
##----------------------------------------------------------------------------
package Markdown::Parser::Link;
BEGIN
{
    use strict;
    use warnings;
    use parent qw( Markdown::Parser::Element );
    use vars qw( $VERSION );
    our $VERSION = 'v0.3.0';
};
use strict;
use warnings;
sub init
{
    my $self = shift( @_ );
    $self->{encrypt}        = '';
    $self->{id}             = [];
    $self->{link_id}        = '';
    $self->{name}           = '';
    $self->{original}       = '';
    $self->{tag_name}       = 'link';
    $self->{title}          = '';
    $self->{url}            = '';
    return( $self->SUPER::init( @_ ) );
}
sub as_markdown
{
    my $self = shift( @_ );
    my $arr = $self->new_array;
    my $name = $self->children->map(sub{ $_->as_markdown })->join( '' );
    $arr->push( sprintf( '[%s]', $name ) );
    if( $self->link_id )
    {
        $arr->push( sprintf( '[%s]', $self->link_id ) );
    }
    elsif( $self->url || $self->title )
    {
        $arr->push( '(' );
        $arr->push( sprintf( '%s', $self->url ) ) if( $self->url );
        $arr->push( ' ' ) if( $self->url && $self->title );
        $arr->push( sprintf( '"%s"', $self->title ) ) if( $self->title );
        $arr->push( ')' );
    }
    if( $self->class->length || $self->id->length )
    {
        my $def = $self->new_array;
        $def->push( $self->id->map(sub{ "\#${_}" })->list );
        $def->push( $self->class->map(sub{ ".$_" })->list );
        $arr->push( '{' . $def->join( ' ' )->scalar . '}' );
    }
    return( $arr->join( '' )->scalar );
}
sub as_pod
{
    my $self = shift( @_ );
    my $arr = $self->new_array;
    my $name = $self->children->map(sub{ $_->as_pod })->join( '' );
    if( $self->url && $name )
    {
        $arr->push( sprintf( 'L<%s|%s>', $name, $self->url ) );
    }
    elsif( $self->url )
    {
        $arr->push( sprintf( 'L<%s>', $self->url ) );
    }
    return( $arr->join( '' )->scalar );
}
sub as_string
{
    my $self = shift( @_ );
    my $arr  = $self->new_array;
    my $tag  = 'a';
    my $tag_open = $tag;
    my $url = $self->url;
    my $orig = $self->original->scalar;
    my $url_str = "$url";
    my $encrypt = $self->encrypt;
    my $scheme = '';
    $scheme = $url->scheme if( ref( $url ) );
    $arr->push( "<${tag_open}" );
    my $attr = $self->new_array;
    $attr->push( $self->format_id ) if( $self->id->length );
    $attr->push( $self->format_class ) if( $self->class->length );
    my $attributes = $self->format_attributes;
    $attr->push( $attributes->join( ' ' )->scalar ) if( $attributes->length );
    $arr->push( ' ' . $attr->join( ' ' )->scalar ) if( $attr->length );
    if( $scheme eq 'mailto' )
    {
        if( $encrypt eq 'obfuscate' )
        {
            $self->document->setup_email_obfuscation;
            # We use the original e-mail address as it as provided in the text, because URI alters it by url-encoding it
            my $email = $orig;
            my $user = substr( $email, 0, rindex( $email, '@' ) );
            my $host = substr( $email, rindex( $email, '@' ) + 1 );
            # Use of a decoy email address
            if( $self->document->default_email->length > 0 )
            {
                $arr->push( sprintf( ' href="%s"', $self->document->default_email->scalar ) );
            }
            else
            {
                $arr->push( " href=\"mailto:dave.null\@${host}\"" );
            }
            my $data_user = $self->document->email_obfuscate_data_user->scalar || 'user';
            my $data_host = $self->document->email_obfuscate_data_host->scalar || 'host';
            $arr->push( sprintf( ' data-%s="%s"', $data_user, $self->encode_html( ['"', '&', '?', '#'], join( '', reverse( split( //, $user ) ) ) ) ) );
            $arr->push( sprintf( ' data-%s="%s"', $data_host, $self->encode_html( ['"', '&', '?', '#'], join( '', reverse( split( //, $host ) ) ) ) ) );
            $self->class->push( $self->document->email_obfuscate_class ) if( !$self->class->has( $self->document->email_obfuscate_class->scalar ) );
            $arr->push( sprintf( ' class="%s"', $self->class->join( ', ' )->scalar ) );
        }
        elsif( $encrypt eq 'encode' || $encrypt )
        {
            $url_str = $self->encode_email_address( $orig );
            $arr->push( " href=\"$url_str\"" );
        }
        else
        {
            $arr->push( " href=\"$url_str\"" );
        }
    }
    else
    {
        $arr->push( " href=\"$url_str\"" );
    }
    if( $self->title->length )
    {
        $arr->push( sprintf( ' title="%s"', $self->encode_html( 'all', $self->title ) ) );
    }
    $arr->push( ">" );
    if( $scheme eq 'mailto' && $encrypt eq 'obfuscate' )
    {
        ## We do nothing
    }
    elsif( $self->children->length )
    {
        $arr->push( $self->children->map(sub{ $_->as_string })->list );
    }
    else
    {
        my $link_text = $scheme eq 'mailto' ? $self->encode_email_address( $orig ) : $orig;
        $arr->push( $link_text );
    }
    $arr->push( "</${tag}>" );
    return( $arr->join( '' )->scalar );
}
sub copy_from
{
    my $self = shift( @_ );
    my $def  = shift( @_ ) || return( $self->error( "No link definition object was provided." ) );
    return( $self->error( "Link definition object provided to copy information from \"", overload::StrVal( $def ), "\" is not a Markdown::Parser::LinkDefinition object." ) ) if( !$self->_is_a( $def, 'Markdown::Parser::LinkDefinition' ) );
    return( $def->copy_to( $self ) );
}
sub encrypt { return( shift->_set_get_scalar_as_object( 'encrypt', @_ ) ); }
sub encode_email_address
{
    my $self = shift( @_ );
    my $addr = shift( @_ );
    return( '' ) if( !length( $addr ) );
    ## Borrowed from Markdown original author John Gruber
        srand();
        ## Use either decimal, hexadecimal or no encoding
        ## https://stackoverflow.com/questions/20357800/html-entities-when-to-use-decimal-vs-hex
        my @encode = 
        (
                sub{ '&#' .                 ord( shift )   . ';' },
                sub{ '&#x' . sprintf( "%X", ord( shift ) ) . ';' },
                sub{                             shift           },
        );
        my @chars = split( //, $addr );
        for my $i ( 0..$#chars )
        {
                if( $chars[$i] eq '@' )
                {
                        ## Markdown's original author John Gruber says: "this *must* be encoded. I insist."
                        $chars[$i] = $encode[ int( rand( 1 ) ) ]->( $chars[$i] );
                }
                elsif( $chars[$i] ne ':' )
                {
                        ## leave ':' alone (to spot mailto: later)
                        my $r = rand();
                        # roughly 10% raw, 45% hex, 45% dec
                        $chars[$i] = (
                                $r > .9   ?  $encode[2]->( $chars[$i] )  :
                                $r < .45  ?  $encode[1]->( $chars[$i] )  :
                                                         $encode[0]->( $chars[$i] )
                        );
                }
        }
        return( join( '', @chars ) );
}
sub link_id { return( shift->_set_get_scalar_as_object( 'link_id', @_ ) ); }
sub name
{
    my $self = shift( @_ );
    if( @_ )
    {
        my $text = shift( @_ );
        return( $self->add_element( $self->create_text({ text => $text }) ) );
    }
    else
    {
        return( $self->children->map(sub{ $_->as_string })->join( '' ) );
    }
}
sub original { return( shift->_set_get_scalar_as_object( 'original', @_ ) ); }
sub title { return( shift->_set_get_scalar_as_object( 'title', @_ ) ); }
sub url { return( shift->_set_get_uri( 'url', @_ ) ); }
1;
# NOTE: POD
__END__
HideShow 103 lines of Pod
=encoding utf8
=head1 NAME
Markdown::Parser::Link - Markdown Link Element
=head1 SYNOPSIS
    my $o = Markdown::Parser::Link->new;
    # or
    $doc->add_element( $o->create_link( @_ ) );
=head1 VERSION
    v0.3.0
=head1 DESCRIPTION
This class represents a link. It is used by L<Markdown::Parser> and inherits from L<Markdown::Parser::Element>
=head1 METHODS
=head2 as_markdown
Returns a string representation of the link formatted in markdown.
It returns a plain string.
=head2 as_pod
Returns a string representation of the link formatted in L<pod|perlpod>.
It returns a plain string.
=head2 as_string
Returns an html representation of the link.
It returns a plain string.
=head2 copy_from
Provided with a L<Markdown::Parser::LinkDefinition> object and this will call L<Markdown::Parser::LinkDefinition/copy_to>
=head2 encrypt
Boolean value to encrypt links that are an e-mail address
=head2 encode_email_address
Given an e-mail address, this use randomly 3 ways to encode it in an attempt to obfuscate and make it harder for spammers to harvest it.
This is based solely on Markdown's original author, John Gruber's code.
=head2 id
Sets or gets the array object of css id for this link. There should only be one set. Stores the value as an L<Module::Generic::Array> object.
=head2 link_id
Sets or gets the link id. Stores the value as an L<Module::Generic::Scalar> object.
Returns the current value.
=head2 name
Sets or gets the link name, i.e. the text highlighted in the link.
In void context, this return the text as a string.
=head2 original
Sets or gets the original link string.
=head2 title
Sets or gets the link title. Stores the value as an L<Module::Generic::Scalar> object.
Returns the current value.
=head2 url
Sets or gets the link url. This stores the value as an L<URL> object.
Returns the current value.
=head1 SEE ALSO
Markdown original author reference on emphasis: L<https://daringfireball.net/projects/markdown/syntax#link>
=head1 AUTHOR
Jacques Deguest E<lt>F<jack@deguest.jp>E<gt>
=head1 COPYRIGHT & LICENSE
Copyright (c) 2020 DEGUEST Pte. Ltd.
You can use, copy, modify and redistribute this package and associated
files under the same terms as Perl itself.
=cut