view release on metacpan or  search on metacpan

bin/org2ical  view on Meta::CPAN

    my(%opts) = @_;
    my $out_ics    =    delete $opts{out_ics};
    my @todo_files = @{ delete $opts{todo_files} };
    my @include_tags = @{ delete $opts{include_tags} || [] };
    my @exclude_tags = @{ delete $opts{exclude_tags} || [] };
    my $domain_id  =    delete $opts{domain_id};
    my $debug      =    delete $opts{debug};
    die "Unhandled options: " . join(" ", %opts) if %opts;

    my($include_tags_rx, $exclude_tags_rx);
    if (@include_tags) {
	$include_tags_rx = ':(' . join('|', map { quotemeta } @include_tags) . '):';
	$include_tags_rx = qr{$include_tags_rx};
    }
    if (@exclude_tags) {
	$exclude_tags_rx = ':(' . join('|', map { quotemeta } @exclude_tags) . '):';
	$exclude_tags_rx = qr{$exclude_tags_rx};
    }

    my %old_events;
    if (-e $out_ics) {
	open my $fh, "<", $out_ics
	    or die "ERROR: Can't open $out_ics: $!";
	binmode $fh, ':encoding(utf-8)';
	my $current_event;
	my $current_uid;
	my $in_event;
	my $in_alarm;
	while(<$fh>) {
	    if (/^BEGIN:VEVENT$/) {
		$current_event = $_;
		$in_event = 1;
	    } elsif (/^END:VEVENT$/) {
		$current_event .= $_;
		if (!$current_uid) {
		    warn "Strange: VEVENT without UID, ignoring...";
		} else {
		    $old_events{$current_uid} = $current_event;
		}
		undef $current_event;
		undef $current_uid;
		$in_event = 0;
	    } elsif ($in_event) {
		if (/^BEGIN:VALARM$/) {
		    $in_alarm = 1;
		} elsif (/^END:VALARM$/) {
		    $in_alarm = 0;
		} elsif (!$in_alarm && /^UID:(.*)$/) {
		    if (defined $current_uid) {
			warn "Strange: multiple UIDs defined, choosing later one...";
		    }
		    $current_uid = $1;
		}
		$current_event .= $_;
	    }
	}
    }

    my $ofh = File::Temp->new(TEMPLATE => 'org2ical-XXXXXXXX', DIR => dirname($out_ics), SUFFIX => '.ics');
    if (-e $out_ics) {
	copy_stat($out_ics, $ofh->filename);
    }
    binmode $ofh, ':encoding(utf-8)';
    print $ofh <<EOF;
BEGIN:VCALENDAR
VERSION:2.0
CALSCALE:GREGORIAN
PRODID:-//Slaven Rezic//NONSGML rezic.de org2ical $VERSION//EN
EOF

    my $hostname = defined $domain_id ? $domain_id : _hostname();

    for my $todo_file (@todo_files) {
	my $todo_mtime = (stat($todo_file))[9];
	my @todo_dates = App::orgdaemon::find_dates_in_org_file($todo_file, include_timeless => 1, time_fallback => '00:00');
    HANDLE_TODO_ITEM: for my $todo_date (reverse @todo_dates) {
	    if ($include_tags_rx) {
		if ($todo_date->{text} !~ $include_tags_rx) {
		    next HANDLE_TODO_ITEM;
		}
	    }
	    if ($exclude_tags_rx) {
		if ($todo_date->{text} =~ $exclude_tags_rx) {
		    next HANDLE_TODO_ITEM;
		}
	    }

	    {
		my $uid = md5_base64(encode_utf8($todo_date->id)) . '@' . $hostname;
		my $dtstamp = strftime "%Y%m%dT%H%M%SZ", gmtime $todo_mtime;
		#my $dtstart = $todo_date->start_is_timeless ? strftime("DTSTART;VALUE=DATE:%Y%m%d", localtime $todo_date->{epoch}) : strftime("DTSTART:%Y%m%dT%H%M%SZ", gmtime $todo_date->{epoch});
		my $dtstart = $todo_date->start_is_timeless ? strftime("DTSTART;VALUE=DATE:%Y%m%d", localtime $todo_date->{epoch}) : strftime("DTSTART:%Y%m%dT%H%M%S", localtime $todo_date->{epoch});
		my $dtend;
		if ($todo_date->date_end) {
		    # rfc5545: If such a "VEVENT" (daily reminder) has a "DTEND" property, it MUST be specified as a DATE value also.
		    #$dtend = $todo_date->end_is_timeless || $todo_date->start_is_timeless ? strftime("DTEND;VALUE=DATE:%Y%m%d", localtime($todo_date->epoch_end + 86400)) : strftime("DTEND:%Y%m%dT%H%M%SZ", gmtime $todo_date->epoch_end);
		    $dtend = $todo_date->end_is_timeless || $todo_date->start_is_timeless ? strftime("DTEND;VALUE=DATE:%Y%m%d", localtime($todo_date->epoch_end + 86400)) : strftime("DTEND:%Y%m%dT%H%M%S", localtime $todo_date->epoch_end);
		}
		my $description = $todo_date->formatted_text; # XXX description vs. summary?
		my $early_warning_min;
		if (!$todo_date->start_is_timeless || $todo_date->early_warning) {
		    $early_warning_min = ceil(($todo_date->{epoch} - ($todo_date->{early_warning_epoch} || 5*60)) / 60);
		} else {
		    $early_warning_min = ceil((16*3600) / 60);
		}
		my $trigger = "TRIGGER:-PT${early_warning_min}M";
		$description =~ s{\s+:.*}{};
		$description =~ s{\s+<.*>$}{};
		$description =~ s{\s*SCHEDULED:\s*}{ };
		$description =~ s{,}{\\,}g;

		# The comment is currently the complete item, except for really boring lines
		# (scheduled date, former state changes, properties...). It feels somewhat
		# hacky, see XXXs below.
		my $comment;
		if (defined $todo_date->{seek} && open my $forward_fh, $todo_file) {
		    seek $forward_fh, $todo_date->{seek}, SEEK_SET or die "seek failed: $!";
		    scalar <$forward_fh>; # overread title line; already in the summary of the vevent
		    while(defined(my $line = decode_utf8(scalar <$forward_fh>))) { # XXX should not assume utf-8 as org file encoding
			last if $line =~ /^\*/;
			if ($line !~ m{^(
					   \s+SCHEDULED:\s+<\d+.*>
				       |   \s+-\s+State\s+"DONE"\s+from\s+"TODO"\s+\[.*\] # XXX other state changes are possible
				       |   \s+:(PROPERTIES|LAST_REPEAT|END): # XXX there are more possible properties
				       |   \s+\[cropped\]$ # XXX private convention
				       )}x) {
			    $comment .= $line;
			}
		    }
		}
		if ($comment) {
		    # handle geo: URIs
		    $comment =~ s{\[\[geo:([-+]?\d+(?:\.\d+)?),([-+]?\d+(?:\.\d+)?)(?:\?z=(\d+(?:\.\d+)?))?\](?:\[(.*?)\])?\]}{geo_to_url($1,$2,$3,$4)}eg;

bin/org2ical  view on Meta::CPAN

		    warn ".ics file, but no diff available\n";
		}
	    }
	}
	cp $out_ics, "$out_ics~";
    }

    rename $ofh->filename, $out_ics
	or die "Renaming " . $ofh->filename . " to $out_ics failed: $!";
}

sub _hostname {
    my $hostname;
    if (is_in_path('hostname')) {
	chomp($hostname = `hostname -f`);
    }
    if (!defined $hostname || $hostname eq '') {
	require Sys::Hostname;
	$hostname = Sys::Hostname::hostname();
    }
    $hostname;
}

sub _get_old_or_new {
    my($new_vcal, $old_vcal) = @_;
    my($new_vcal_cmp, $old_vcal_cmp);
    for my $def (
	      [$new_vcal, \$new_vcal_cmp],
	      [$old_vcal, \$old_vcal_cmp],
	     ) {
	my($src, $destref) = @$def;
	for my $l (split /\n/, $src) {
	    if ($l !~ m{^(CREATED|DTSTAMP|LAST-MODIFIED):}) {
		$$destref .= $l;
		$$destref .= "\n";
	    }
	}
    }
    if ($new_vcal_cmp eq $old_vcal_cmp) {
	$old_vcal;
    } else {
	$new_vcal;
    }
}

sub geo_to_url {
    my($lat,$lon,$zoom,$link_title) = @_;
    $zoom = 15 if !defined $zoom;
    my $url = sprintf "https://www.openstreetmap.org/?mlat=%s&mlon=%s#map=%s/%s/%s", $lat, $lon, $zoom, $lat, $lon;
    if (defined $link_title) {
	"$url ($link_title)";
    } else {
	$url;
    }
}

# REPO BEGIN
# REPO NAME copy_stat /home/eserte/src/srezic-repository 
# REPO MD5 f567def1f7ce8f3361e474b026594660

#=head2 copy_stat($src, $dest)
#
#=for category File
#
#Copy stat information (owner, group, mode and time) from one file to
#another. If $src is an array reference, then this is used as the
#source stat information.
#
#=cut

sub copy_stat {
    my($src, $dest) = @_;
    my @stat = ref $src eq 'ARRAY' ? @$src : stat($src);
    die "Can't stat $src: $!" if !@stat;

    chmod $stat[2], $dest
	or warn "Can't chmod $dest to " . sprintf("0%o", $stat[2]) . ": $!";
    chown $stat[4], $stat[5], $dest
	or do {
	    my $save_err = $!; # otherwise it's lost in the get... calls
	    warn "Can't chown $dest to " .
		 (getpwuid($stat[4]))[0] . "/" .
                 (getgrgid($stat[5]))[0] . ": $save_err";
	};
    utime $stat[8], $stat[9], $dest
	or warn "Can't utime $dest to " .
	        scalar(localtime $stat[8]) . "/" .
		scalar(localtime $stat[9]) .
		": $!";
}
# REPO END

# REPO BEGIN
# REPO NAME is_in_path /home/eserte/src/srezic-repository 
# REPO MD5 4be1e368fea0fa9af4e89256a9878820

#=head2 is_in_path($prog)
#
#=for category File
#
#Return the pathname of $prog, if the program is in the PATH, or undef
#otherwise.
#
#=cut

sub is_in_path {
    my($prog) = @_;
    require File::Spec;
    if (File::Spec->file_name_is_absolute($prog)) {
	if ($^O eq 'MSWin32') {
	    return $prog       if (-f $prog && -x $prog);
	    return "$prog.bat" if (-f "$prog.bat" && -x "$prog.bat");
	    return "$prog.com" if (-f "$prog.com" && -x "$prog.com");
	    return "$prog.exe" if (-f "$prog.exe" && -x "$prog.exe");
	    return "$prog.cmd" if (-f "$prog.cmd" && -x "$prog.cmd");
	} else {
	    return $prog if -f $prog and -x $prog;
	}
    }
    require Config;
    %Config::Config = %Config::Config if 0; # cease -w
    my $sep = $Config::Config{'path_sep'} || ':';
    foreach (split(/$sep/o, $ENV{PATH})) {
	if ($^O eq 'MSWin32') {
	    # maybe use $ENV{PATHEXT} like maybe_command in ExtUtils/MM_Win32.pm?
	    return "$_\\$prog"     if (-f "$_\\$prog" && -x "$_\\$prog");
	    return "$_\\$prog.bat" if (-f "$_\\$prog.bat" && -x "$_\\$prog.bat");
	    return "$_\\$prog.com" if (-f "$_\\$prog.com" && -x "$_\\$prog.com");
	    return "$_\\$prog.exe" if (-f "$_\\$prog.exe" && -x "$_\\$prog.exe");
	    return "$_\\$prog.cmd" if (-f "$_\\$prog.cmd" && -x "$_\\$prog.cmd");
	} else {
	    return "$_/$prog" if (-x "$_/$prog" && !-d "$_/$prog");
	}