cgi/shorten.pl


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117

#!/usr/bin/perl 
use strict;
use warnings;
use DBI;
use open ':std',':utf8';
use Encode;
use 5.12.0;
 
my $db=DBI->connect('dbi:SQLite:dbname=urls.db','','',{
    PrintError => 0,
    RaiseError => 1,
    AutoCommit => 1,
    sqlite_unicode => 1,
});
 
my $dbversion=eval {
    $db->selectall_arrayref('select version from metainfo',{Slice=>{}})
        ->[0]{version};
};
if (!defined $dbversion) {
    $db->do(q{create table metainfo(version integer not null)});
    $db->do(q{create table url(url varchar not null unique,shorted varchar not null unique)});
    $db->do(q{insert into metainfo(version) values(1)});
}
 
{
# these could be multiple ranges 
my @ranges=(0x4e00,0x9fcb);
my $base=0;
for(my $i=0;$i<@ranges;$i+=2) {
    $base+=$ranges[$i+1]-$ranges[$i];
}
sub num2chars {
    my ($number) = @_;
 
    my @ret=();
    while ($number >= $base) {
        unshift @ret,$number % $base;
        $number=int($number/$base);
    }
    unshift @ret,$number;
 
    for my $v (@ret) {
        for(my $i=0;$i<@ranges;$i+=2) {
            $v+=$ranges[$i];
            last
                if $v<$ranges[$i+1];
            $v-=$ranges[$i+1];
        }
    }
    return @ret;
}
}
 
sub shorten {
    my ($url) = @_;
 
    my $ret=$db->selectall_arrayref(q{select shorted from url where url=?},
                                    {Slice=>{}},
                                    $url);
    if (@$ret) {
        return $ret->[0]{shorted};
    }
 
    $ret=$db->selectall_arrayref(q{select count(*) as howmany from url},
                                 {Slice=>{}});
    my $number = $ret->[0]{howmany};
    my @codepoints=num2chars($number);
    my $short=pack 'U0U*',@codepoints;
    $db->do(q{insert into url(url,shorted) values (?,?)},
            {},
            $url,$short);
    return $short;
}
 
sub lengthen {
    my ($short) = @_;
    my $ret=$db->selectall_arrayref(q{select url from url where shorted=?},
                                    {Slice=>{}},
                                    $short);
    if (@$ret) {
        return $ret->[0]{url};
    }
    return 404;
}
 
sub urlencode {
    my ($str) = @_;
 
    my @bytes = unpack 'U0C*',$str;
    return join '',map {sprintf '%%%02X',$_} @bytes;
}
 
sub urldecode {
    my ($str) = @_;
 
    my @pieces = ($str =~ m{%(..)}g);
    my @bytes = map { oct("0x$_") } @pieces;
    return pack 'U0C*',@bytes;
}
 
if (@ARGV>1) {
    my $str=$ARGV[1];
    if ($str =~ m{^%}) {
        $str=urldecode($str);
    }
    else {
        $str=decode('utf8',$str);
    }
    say lengthen($str);
}
else {
    my $url=$ARGV[0];
    my $str=shorten($url);
    say $str;
    say urlencode($str);
}