UCW/Temple/Links.pm

   1 #!/usr/bin/perl
   2 # A really simple template engine: Link helpers
   3 # (c) 2008 Martin Mares <mj@ucw.cz>
   4
   5 package UCW::Temple::Links;
   6
   7 use strict;
   8 use warnings;
   9
  10 require Exporter;
  11 our $VERSION = 1.0;
  12 our @ISA = qw(Exporter);
  13 our @EXPORT = qw(url href normalize_url);
  14 our @EXPORT_OK = qw();
  15
  16 our $relpath;           # relative path from the root of the tree to the current file
  17 our $rootpath;          # relative path from the current URL back to the root of the tree
  18
  19 sub init($$)
  20 {
  21         my ($destpath, $destdir) = @_;
  22
  23         $relpath = $destpath;
  24         $relpath =~ s{^$destdir/}{};
  25         $relpath =~ s{^\./}{};
  26         my @tmp = split(m{/}, "$relpath.");
  27         my $dircnt = @tmp;
  28         $rootpath = "";
  29         while ($dircnt-- > 1) {
  30                 $rootpath .= "../";
  31         }
  32         #print STDERR "DESTPATH: $destpath, DESTDIR: $destdir -> RELPATH: $relpath, ROOTPATH: $rootpath\n";
  33
  34         return;
  35 }
  36
  37 # Compose a relative path with its absolute base
  38 sub compose_path($$) {
  39         my ($base, $rel) = @_;
  40         return $rel if $rel =~ m{^/};
  41         $base =~ s{/[^/]*$}{/};
  42         while ($rel =~ s{^\.(\.)?/}{}) {
  43                 $base =~ s{(^|/)[^/]+/$}{$1} if defined($1);
  44         }
  45         return $base . $rel;
  46 }
  47
  48 # Change $url to be relative to $base
  49 sub relativize_path($$) {
  50         my ($base, $url) = @_;
  51         my @b = split m{/}, $base;
  52         pop @b unless $base =~ m{/$};
  53         my @u = split m{/}, $url;
  54         push @u, "" if $url =~ m{/$};
  55         push @u, "" if $url eq "/";
  56         # print STDERR "B: <", join(":", @b), "> ", scalar @b, "\n";
  57         # print STDERR "U: <", join(":", @u), "> ", scalar @u, "\n";
  58         while (@b && @u && $b[0] eq $u[0]) {
  59                 shift @b;
  60                 shift @u;
  61         }
  62         return join("/", (map { ".." } @b), @u);
  63 }
  64
  65 sub normalize_url($) {
  66         my $url = shift @_;
  67         $url =~ s{(^|/)index\.\w+$}{$1};
  68         $url ne "" or $url = "./";
  69         return $url;
  70 }
  71
  72 sub url($) {
  73         my $url = shift @_;
  74         $url = compose_path("/$relpath", $url);
  75         $url = relativize_path("/$relpath", $url);
  76         return normalize_url($url);
  77 }
  78
  79 sub href($) {
  80         return '"' . url($_[0]) . '"';
  81 }
  82
  83 42;