Tex2fb2

   1 #!/usr/bin/perl -CDS
   2 use utf8;
   3 # char-level modes
   4 my $poetry = 0;
   5 my $verbatim = 0;
   6 my @sections;
   7 my $buffer;
   8 #
   9 # TODO italic paragaphs
  10 # footnotes
  11 # epigraphs
  12 #
  13 # print fictionbook header
  14 print "<?xml version=\"1.0\" encoding=\"UTF-8\">\n";
  15 print "<FictionBook xmlns=\"http://www.gribuser.ru/xml/fictionbook/2.0\"
  16 xmlns:l=\"http://www.w3.org/1999/xlink\">\n";
  17 my $metadata = shift @ARGV;
  18 open F,"<",$metadata;
  19 while (<F>) {
  20         print $_;
  21 }
  22 close F;
  23
  24 my $header =1;
  25 LINE:
  26 while (<>) {
  27 $environ = undef;
  28 if (/\\(begin|end){(\w+)}/) {
  29         $environ = $2;
  30         $begin=$1 eq "begin";
  31         if ($environ eq 'verbatim') {
  32                 $verbatim=$begin;
  33         } elsif ($environ eq 'verse') {
  34                 if ($begin) {
  35                 pushsection("poem",undef);
  36                 } else {
  37                 flushsection('poem');
  38                 }
  39                 $poetry = $begin;
  40         } elsif($environ = 'document' && $begin) {
  41                 $header=0;
  42         }
  43 }
  44 next LINE if $header;
  45 if ((/^$/ || $environ) && $buffer) {
  46 #output on empty line (p or stanza) depending on poetry mode
  47         add_to_section(tag($buffer,$poetry?"stanza":"p"));
  48         $buffer="";
  49 }
  50 next LINE if $environ;
  51 # Section headings
  52 if (/\\(part|chapter|section|subsection|subsubsection)\*?{(.*)}/) {
  53         if ($buffer) {
  54                 add_to_section(tag($buffer,$poetry?"stanza":"p"));
  55                 $buffer="";
  56         }
  57         pushsection($1,$2);
  58         next LINE;
  59 }
  60 if (/\\vspace{/) {
  61         add_to_section("<empty-line />");
  62         next LINE;
  63 }
  64 #normal mode:
  65 if (!$verbatim) {
  66 #strip TeX comments
  67 s/([^\\])%.*$/$1/;
  68 s/^%.*$//;
  69 # strip \sloppy
  70 s/\\sloppy\s+//g;
  71 s/\\sloppy{}//g;
  72 s/\\sloppy([^\w])/$1/g;
  73 #replace TeX ligatures ~ --- << >> \% with appropriate unicode symbols
  74 s/~/\xA0/g;
  75 s/---/-/g;
  76 s/<</«/g;
  77 s/>>/»/g;
  78 s/\\%/%/g;
  79 s/\\dots/\x{2026}/g;
  80 }
  81 #replace ' and " with entities
  82 s/&/&amp;/g;
  83 s/'/&apos;/g;
  84 s/"/&quot;/g;
  85 s/</&lt;/g;
  86 s/>/&gt;/g;
  87
  88 if ($poetry) {
  89         chomp;
  90   $buffer.=tag($_,'v');
  91 } elsif ($verbatim) {
  92         add_to_section(tag(tag($_,"code"),"p"));
  93 } else {
  94   $buffer.=$_;
  95 }
  96 }
  97 if ($buffer) {
  98         add_to_section(tag($buffer,"p"));
  99         $buffer="";
 100 }
 101
 102 while (@sections) {
 103         flushsection();
 104 }
 105 print "</body>\n";
 106 ## FIXME print footnotes
 107 print "</FictionBook>";
 108
 109 sub add_to_section {
 110         my $data = shift;
 111         return if ($#sections<0) ;
 112         $sections[$#sections]->{data}.=$data;
 113 }
 114
 115 sub flushsection {
 116         my $tag= shift || 'section';
 117         my $str = pop @sections;
 118         my $content="";
 119         if ($str->{title}) {
 120                 $content = tag($str->{title},"title");
 121         }
 122         $content .=  $str->{data};
 123         if ($#sections >=0) {
 124                 add_to_section(tag($content,$tag));
 125         } else {
 126                 print tag($content,$tag);
 127         }
 128 }
 129
 130 sub pushsection {
 131         my ($level,$title)=@_;
 132         # Find section of $level in the current stack
 133         my $found=scalar(@sections);
 134         LEVEL:
 135         for (my $i=0;$i<=$#sections;$i++) {
 136                 if ($sections[$i]->{level} eq $level) {
 137                         $found=$i;
 138                         last LEVEL;
 139                 }
 140         }
 141         # if found, flush everything below
 142         while (scalar(@sections) > $found) {
 143                 flushsection;
 144         }
 145         push @sections,{level=>$level,title=>$title,data=>""};
 146 }
 147
 148 sub tag {
 149         my ($content,$name) = @_;
 150         return "" if ($content eq "\n");
 151         return "<$name>$content</$name>";
 152 }